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 )
import qualified Data.ByteString.Lazy.Char8 as Char8L ( toChunks )
import qualified Data.ByteString.Lazy as L ( fromChunks )
import qualified Data.Digest.Pure.SHA as SHA
( bytestringDigest, hmacSha256 )
import Network.TCP ( HStream(close, openStream) )
import Network.URI
( URIAuth(URIAuth, uriPort, uriRegName, uriUserInfo), URI(..) )
import Network.HTTP
( HeaderName(HdrAccept, HdrAuthorization, HdrContentLength,
HdrContentType, HdrDate),
Header(..),
Request(Request, rqBody, rqHeaders, rqMethod, rqURI),
RequestMethod,
Response_String,
sendHTTP )
import Network.HTTP.Base ()
import Network.Stream ( Result )
import Network.TableStorage.Types
( SharedKeyAuth(..),
Account(accountHost, accountKey, accountName, accountPort,
accountResourcePrefix, accountScheme),
AuthHeader(..),
Signature(..),
AccountKey(unAccountKey) )
import Network.TableStorage.Format ( rfc1123Date )
authenticationType :: String
authenticationType = "SharedKey"
printSharedKeyAuth :: SharedKeyAuth -> String
printSharedKeyAuth auth =
show (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 :: Account -> RequestMethod -> [Header] -> String -> String -> String -> IO (Either String Response_String)
authenticatedRequest acc method hdrs resource canonicalizedResource body = do
time <- rfc1123Date
connection <- openStream (accountHost acc) (accountPort acc)
let { auth = SharedKeyAuth
{ sharedKeyAuthVerb = method
, sharedKeyAuthContentMD5 = ""
, sharedKeyAuthContentType = "application/atom+xml"
, sharedKeyAuthDate = time
, sharedKeyAuthCanonicalizedResource = "/" ++ accountName acc ++ accountResourcePrefix acc ++ canonicalizedResource } }
let { basicHeaders =
[ Header HdrAuthorization $ unAuthHeader $ authHeader acc auth
, Header HdrContentType "application/atom+xml"
, Header HdrContentLength $ show $ length body
, Header HdrAccept "application/atom+xml,application/xml"
, Header HdrDate time ] }
let { request = Request
{ rqURI = qualifyResource resource acc
, rqMethod = method
, rqHeaders = basicHeaders ++ hdrs
, rqBody = body } }
result <- sendHTTP connection request :: IO (Result Response_String)
_ <- close connection
return $ either (Left . show) Right result