forked from paf31/tablestorage
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Auth.hs
132 lines (123 loc) · 5.43 KB
/
Auth.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
{-# LANGUAGE OverloadedStrings #-}
-- |
-- This module provides functions to create authenticated requests to the Table
-- Storage REST API.
--
-- Functions are provided to create Shared Key authorization tokens, and to add the
-- required headers for the various requests.
--
module Network.TableStorage.Auth (
authenticatedRequest
) where
import qualified Data.ByteString.Base64 as Base64C
( encode, decode )
import qualified Codec.Binary.UTF8.String as UTF8C ( encodeString )
import qualified Data.ByteString as B ( ByteString, concat )
import qualified Data.ByteString.UTF8 as UTF8
( toString, fromString )
import qualified Data.ByteString.Lazy.UTF8 as UTF8L ( fromString, toString )
import qualified Data.ByteString.Lazy.Char8 as Char8L ( toChunks )
import qualified Data.ByteString.Lazy as L ( ByteString, fromChunks )
import qualified Crypto.Classes as Crypto ( encode )
import Crypto.Hash.MD5 as MD5 (hash)
import qualified Data.Digest.Pure.SHA as SHA
( bytestringDigest, hmacSha256 )
import Network.URI
( URIAuth(URIAuth, uriPort, uriRegName, uriUserInfo), URI(..) )
import Network.Socket.Internal (withSocketsDo)
import Network.HTTP.Conduit
import Network.HTTP.Conduit.Internal (setUri)
import Network.HTTP.Types
import Network.TableStorage.Types
import Network.TableStorage.Format ( rfc1123Date )
import Data.Monoid ((<>))
import Debug.Trace
import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.IO.Class
authenticationType :: String
authenticationType = "SharedKey"
-- |
-- Constructs the unencrypted content of the Shared Key authentication token
--
printSharedKeyAuth :: SharedKeyAuth -> String
printSharedKeyAuth auth =
(UTF8.toString $ sharedKeyAuthVerb auth)
++ "\n"
++ sharedKeyAuthContentMD5 auth
++ "\n"
++ sharedKeyAuthContentType auth
++ "\n"
++ sharedKeyAuthDate auth
++ "\n"
++ sharedKeyAuthCanonicalizedResource auth
hmacSha256' :: AccountKey -> String -> B.ByteString
hmacSha256' base64Key =
let (Right key) = Base64C.decode . UTF8.fromString . unAccountKey $ base64Key in
B.concat . Char8L.toChunks . SHA.bytestringDigest . SHA.hmacSha256 (L.fromChunks $ return key) . UTF8L.fromString
-- |
-- Constructs the authorization signature
--
signature :: AccountKey -> SharedKeyAuth -> Signature
signature key = Signature . UTF8.toString . Base64C.encode . hmacSha256' key . UTF8C.encodeString . printSharedKeyAuth
-- |
-- Constructs the authorization header including account name and signature
--
authHeader :: Account -> SharedKeyAuth -> AuthHeader
authHeader acc auth = AuthHeader $
authenticationType
++ " "
++ accountName acc
++ ":"
++ unSignature (signature (accountKey acc) auth)
-- |
-- Constructs an absolute URI from an Account and relative URI
--
qualifyResource :: String -> Account -> URI
qualifyResource res acc =
URI { uriScheme = accountScheme acc
, uriAuthority =
Just URIAuth
{ uriRegName = accountHost acc
, uriPort = ':' : show (accountPort acc)
, uriUserInfo = "" }
, uriQuery = ""
, uriFragment = ""
, uriPath = accountResourcePrefix acc ++ res }
-- |
-- Creates and executes an authenticated request including the Authorization header.
--
-- The function takes the account information, request method, additional headers,
-- resource, canonicalized resource and request body as parameters, and returns
-- an error message or the response object.
--
authenticatedRequest :: Method -> [Header] -> String -> String -> String -> TableStorage QueryResponse
authenticatedRequest method hdrs resource canonicalizedResource body = do
time <- liftIO $ rfc1123Date
(TableConf mgr acc) <- ask
let contentMD5 = (Base64C.encode . hash . UTF8.fromString) body
let atomType = "application/atom+xml" :: B.ByteString
let auth = SharedKeyAuth { sharedKeyAuthVerb = method
, sharedKeyAuthContentMD5 = UTF8.toString contentMD5
, sharedKeyAuthContentType = UTF8.toString atomType
, sharedKeyAuthDate = time
, sharedKeyAuthCanonicalizedResource = "/" ++ accountName acc ++ accountResourcePrefix acc ++ canonicalizedResource }
let uri = qualifyResource resource acc
let defaultReq = def { method = method
, requestHeaders = [ (hAuthorization, UTF8.fromString . unAuthHeader $ authHeader acc auth)
, (hContentType, atomType)
, (hContentMD5, contentMD5)
, (hAccept, atomType <> ",application/xml")
, (hDate, UTF8.fromString $ time)
, ("x-ms-date", UTF8.fromString $ time)
, ("x-ms-version", "2009-09-19")
, ("DataServiceVersion", "1.0;NetFx")
, ("MaxDataServiceVersion", "2.0;NetFx")
] ++ hdrs
, requestBody = RequestBodyBS $ UTF8.fromString body
, redirectCount = 0
, checkStatus = \_ _ -> Nothing
}
request <- setUri defaultReq uri
response <- withManager (httpLbs request)
return $ QueryResponse (responseStatus response) (UTF8L.toString $ responseBody response)