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 ( fromChunks )
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.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 Control.Monad.Reader
import Control.Monad.Trans.Resource
authenticationType :: String
authenticationType = "SharedKey"
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
signature :: AccountKey -> SharedKeyAuth -> Signature
signature key = Signature . UTF8.toString . Base64C.encode . hmacSha256' key . UTF8C.encodeString . printSharedKeyAuth
authHeader :: Account -> SharedKeyAuth -> AuthHeader
authHeader acc auth = AuthHeader $
authenticationType
++ " "
++ accountName acc
++ ":"
++ unSignature (signature (accountKey acc) auth)
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 }
authenticatedRequest :: Method -> [Header] -> String -> String -> String -> TableStorage QueryResponse
authenticatedRequest mthd hdrs resource canonicalizedResource body = do
time <- liftIO rfc1123Date
(TableConf acc maybeMgr maybeProxy) <- ask
let contentMD5 = (Base64C.encode . hash . UTF8.fromString) body
let atomType = "application/atom+xml" :: B.ByteString
let auth = SharedKeyAuth { sharedKeyAuthVerb = mthd
, 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 = mthd
, 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
, proxy = maybeProxy
}
request <- setUri defaultReq uri
response <- case maybeMgr of
Just mgr -> runResourceT $ httpLbs request mgr
Nothing -> withManager (httpLbs request)
return $ QueryResponse (responseStatus response) (UTF8L.toString $ responseBody response)