module Network.AWS.Authentication (
runAction, isAmzHeader, preSignedURI,
S3Action(..),
mimeEncodeQP, mimeDecode
) where
import Network.AWS.AWSResult
import Network.AWS.AWSConnection
import Network.AWS.ArrowUtils
import Network.HTTP as HTTP
import Network.URI as URI
import Data.HMAC
import Codec.Binary.Base64 (encode, decode)
import Codec.Utils (Octet)
import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower)
import Data.Bits ((.&.))
import qualified Codec.Binary.UTF8.String as US
import Codec.Utils (Octet)
import Data.List (sortBy, groupBy, intersperse)
import Data.Maybe
import System.Time
import System.Locale
import Text.Regex
import Control.Arrow
import Text.XML.HXT.Arrow
data S3Action =
S3Action {
s3conn :: AWSConnection,
s3bucket :: String,
s3object :: String,
s3query :: String,
s3metadata :: [(String, String)],
s3body :: String,
s3operation :: RequestMethod
} deriving (Show)
requestFromAction :: S3Action
-> HTTP.Request
requestFromAction a =
Request { rqURI = URI { uriScheme = "",
uriAuthority = Nothing,
uriPath = canonicalizeResource a,
uriQuery = s3query a,
uriFragment = "" },
rqMethod = s3operation a,
rqHeaders = [Header HdrHost (awsHost (s3conn a))] ++
(headersFromAction a),
rqBody = s3body a
}
where path = (s3bucket a) ++ "/" ++ (s3object a)
headersFromAction :: S3Action
-> [Header]
headersFromAction a = map (\(k,v) -> case k of
"Content-Type" -> Header HdrContentType v
otherwise -> (Header (HdrCustom k)) (mimeEncodeQP v))
(s3metadata a)
addContentLengthHeader :: HTTP.Request -> HTTP.Request
addContentLengthHeader req = insertHeader HdrContentLength (show (length (rqBody req))) req
addAuthenticationHeader :: S3Action
-> HTTP.Request
-> HTTP.Request
addAuthenticationHeader act req = insertHeader HdrAuthorization auth_string req
where auth_string = "AWS " ++ (awsAccessKey conn) ++ ":" ++ signature
signature = makeSignature conn (stringToSign act req)
conn = s3conn act
makeSignature :: AWSConnection
-> String
-> String
makeSignature c s =
encode (hmac_sha1 keyOctets msgOctets)
where keyOctets = string2words (awsSecretKey c)
msgOctets = string2words s
stringToSign :: S3Action -> HTTP.Request -> String
stringToSign a r =
(canonicalizeHeaders r) ++
(canonicalizeAmzHeaders r) ++
(canonicalizeResource a)
canonicalizeHeaders :: HTTP.Request -> String
canonicalizeHeaders r =
http_verb ++ "\n" ++
hdr_content_md5 ++ "\n" ++
hdr_content_type ++ "\n" ++
dateOrExpiration ++ "\n"
where http_verb = show (rqMethod r)
hdr_content_md5 = get_header HdrContentMD5
hdr_date = get_header HdrDate
hdr_content_type = get_header HdrContentType
get_header h = maybe "" id (findHeader h r)
dateOrExpiration = maybe hdr_date id (findHeader HdrExpires r)
canonicalizeAmzHeaders :: HTTP.Request -> String
canonicalizeAmzHeaders r =
let amzHeaders = filter isAmzHeader (rqHeaders r)
amzHeaderKV = map headerToLCKeyValue amzHeaders
sortedGroupedHeaders = groupHeaders (sortHeaders amzHeaderKV)
uniqueHeaders = combineHeaders sortedGroupedHeaders
in concat (map (\a -> a ++ "\n") (map showHeader uniqueHeaders))
showHeader :: (String, String) -> String
showHeader (k,v) = k ++ ":" ++ removeLeadingWhitespace(fold_whitespace v)
fold_whitespace :: String -> String
fold_whitespace s = subRegex (mkRegex "\n\r( |\t)+") s " "
removeLeadingWhitespace :: String -> String
removeLeadingWhitespace s = subRegex (mkRegex "^( |\t)+") s ""
combineHeaders :: [[(String, String)]] -> [(String, String)]
combineHeaders h = map mergeSameHeaders h
mergeSameHeaders :: [(String, String)] -> (String, String)
mergeSameHeaders h@(x:xs) = let values = map snd h
in ((fst x), (concat $ intersperse "," values))
groupHeaders :: [(String, String)] -> [[(String, String)]]
groupHeaders = groupBy (\a b -> (fst a) == (fst b))
sortHeaders :: [(String, String)] -> [(String, String)]
sortHeaders = sortBy (\a b -> (fst a) `compare` (fst b))
headerToLCKeyValue :: Header -> (String, String)
headerToLCKeyValue (Header k v) = (map toLower (show k), (mimeEncodeQP v))
isAmzHeader :: Header -> Bool
isAmzHeader h =
case h of
Header (HdrCustom k) v -> isPrefix amzHeader k
otherwise -> False
isPrefix :: Eq a => [a] -> [a] -> Bool
isPrefix a b = a == take (length a) b
amzHeader = "x-amz-"
canonicalizeResource :: S3Action -> String
canonicalizeResource a = bucket ++ uri
where uri = case (s3object a) of
"" -> ""
otherwise -> "/" ++ (s3object a)
bucket = case (s3bucket a) of
b@(x:xs) -> "/" ++ b
otherwise -> case uri of
[] -> "/"
otherwise -> ""
addDateToReq :: HTTP.Request
-> String
-> HTTP.Request
addDateToReq r d = r {HTTP.rqHeaders =
(HTTP.Header HTTP.HdrDate d) : (HTTP.rqHeaders r)}
addExpirationToReq :: HTTP.Request -> String -> HTTP.Request
addExpirationToReq r e = addHeaderToReq r (HTTP.Header HTTP.HdrExpires e)
addHeaderToReq :: HTTP.Request -> Header -> HTTP.Request
addHeaderToReq r h = r {HTTP.rqHeaders = h : (HTTP.rqHeaders r)}
httpCurrentDate :: IO String
httpCurrentDate =
do c <- getClockTime
let utc_time = (toUTCTime c) {ctTZName = "GMT"}
return $ formatCalendarTime defaultTimeLocale rfc822DateFormat utc_time
string2words :: String -> [Octet]
string2words = US.encode
runAction :: S3Action -> IO (AWSResult Response)
runAction a = do c <- openTCPPort (awsHost (s3conn a)) (awsPort (s3conn a))
cd <- httpCurrentDate
let aReq = addAuthenticationHeader a $
addContentLengthHeader $
addDateToReq (requestFromAction a) cd
result <- (simpleHTTP_ c aReq)
createAWSResult result
preSignedURI :: S3Action
-> Integer
-> URI
preSignedURI a e =
let c = (s3conn a)
server = (awsHost c)
port = (show (awsPort c))
accessKeyQuery = "AWSAccessKeyId=" ++ (awsAccessKey c)
secretKey = (awsSecretKey c)
beginQuery = case (s3query a) of
"" -> "?"
x -> x ++ "&"
expireQuery = "Expires=" ++ (show e)
toSign = "GET\n\n\n" ++ (show e) ++ "\n/" ++ (s3bucket a) ++ "/" ++ (s3object a)
sigQuery = "Signature=" ++ (urlEncode (makeSignature c toSign))
query = beginQuery ++ accessKeyQuery ++ "&" ++
expireQuery ++ "&" ++ sigQuery
in URI { uriScheme = "http:",
uriAuthority = Just (URIAuth "" server (":" ++ port)),
uriPath = "/" ++ (s3bucket a) ++ "/" ++ (s3object a),
uriQuery = query,
uriFragment = ""
}
createAWSResult :: Result Response -> IO (AWSResult Response)
createAWSResult b = either (handleError) (handleSuccess) b
where handleError x = return (Left (NetworkError x))
handleSuccess x = case (rspCode x) of
(2,y,z) -> return (Right x)
otherwise -> do err <- parseRestErrorXML (rspBody x)
return (Left err)
parseRestErrorXML :: String -> IO ReqError
parseRestErrorXML x =
do e <- runX (readString [(a_validate,v_0)] x
>>> processRestError)
case e of
[] -> return (AWSError "NoErrorInMsg"
("HTTP Error condition, but message body"
++ "did not contain error code."))
x:xs -> return x
processRestError = deep (isElem >>> hasName "Error") >>>
split >>> first (text <<< atTag "Code") >>>
second (text <<< atTag "Message") >>>
unsplit (\x y -> AWSError x y)
mimeEncodeQP, mimeDecode :: String -> String
mimeDecode a =
if isPrefix utf8qp a
then US.decodeString $ mimeDecode' $ reverse $ drop 2 $ reverse $ drop (length utf8qp) a
else a
where
utf8qp = "=?UTF-8?Q?"
mimeDecode' :: String -> String
mimeDecode' ('=':a:b:rest) =
chr (16 * digitToInt a + digitToInt b)
: mimeDecode' rest
mimeDecode' (h:t) = h : mimeDecode' t
mimeDecode' [] = []
mimeEncodeQP s =
if (any (\x -> ord x > 128) s )
then "=?UTF-8?Q?" ++ (mimeEncodeQP' $ US.encodeString s) ++ "?="
else s
mimeEncodeQP' :: String -> String
mimeEncodeQP' (h:t) =
let str = if reserved (ord h) then escape h else [h]
in str ++ mimeEncodeQP' t
where
reserved x
| x >= ord 'a' && x <= ord 'z' = False
| x >= ord 'A' && x <= ord 'Z' = False
| x >= ord '0' && x <= ord '9' = False
| x == ord ' ' = False
| x <= 0x20 || x >= 0x7F = True
| otherwise = True
escape x =
let y = ord x in
[ '=', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]
mimeEncodeQP' [] = []