{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module Akamai.NetStorage
( Auth(..)
, Contents(..)
, NetStoragePath
, mkReq
, download
, dir
, stat
, delete
, upload
) where
import Control.Exception.Base (SomeException)
import Crypto.Hash.Algorithms
import Crypto.MAC.HMAC
import Data.Aeson.TH
import Data.ByteArray.Encoding (convertToBase, Base (Base64))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import Data.Char (toLower)
import Conduit (MonadUnliftIO)
import Data.Conduit
import Data.Int (Int64)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.UnixTime hiding (UnixTime)
import Data.Word (Word32)
import Foreign.C.Types (CTime)
import Network.HTTP.Client (responseBody)
import Network.HTTP.Simple
import System.Random (randomIO)
import Text.XML
import Text.XML.Cursor
import Control.Monad.IO.Class
type UnixTime = CTime
type UniqueId = Word32
type KeyName = Text
type NetStoragePath = ByteString
type AuthData = ByteString
type Key = Text
type Message = ByteString
type AuthSign = ByteString
type Action = ByteString
type SignString = ByteString
data Auth = Auth
{ authHostname :: Text
, authKeyName :: KeyName
, authKey :: Key
, authCpCode :: Int64
, authSsl :: Bool
} deriving (Show,Read,Eq)
$(deriveJSON defaultOptions{fieldLabelModifier = (map toLower) . (drop 4)} ''Auth)
data Contents = File
{ fileName :: Text
, fileSize :: Int64
, fileMd5 :: Text
, fileMtime :: Int64
} | Dir
{ dirName :: Text
} | Symlink
{ symlinkName :: Text
} deriving (Show,Read,Eq)
$(deriveJSON defaultOptions ''Contents)
authData :: UnixTime -> UniqueId -> KeyName -> AuthData
authData ut uid kname = "5, 0.0.0.0, 0.0.0.0, " <> fromString (show ut) <> ", " <> fromString (show uid) <> ", " <> T.encodeUtf8 kname
signString :: NetStoragePath -> Action -> SignString
signString path action = path <> "\n" <> "x-akamai-acs-action:" <> action <> "\n"
authSign :: Key -> Message -> AuthSign
authSign key msg = convertToBase Base64 $ (hmac (T.encodeUtf8 key) msg :: HMAC SHA256)
auth' :: UnixTime -> UniqueId -> KeyName -> NetStoragePath -> Action -> Key -> (AuthData,AuthSign)
auth' ut uid kname path action key = (ad, sign)
where
ad = authData ut uid kname
msg = ad <> signString path action
sign = authSign key msg
authHeaders :: UnixTime -> UniqueId -> KeyName -> NetStoragePath -> Action -> Key -> RequestHeaders
authHeaders ut uid kname path action key =
[
("X-Akamai-ACS-Action", action)
, ("X-Akamai-ACS-Auth-Data", ad)
, ("X-Akamai-ACS-Auth-Sign", sign)
, ("Accept-Encoding", "identity")
, ("User-Agent", "NetStorageKit-Haskell")
]
where
(ad, sign) = auth' ut uid kname path action key
parseContents :: ByteString -> Either SomeException [Contents]
parseContents bin =
case parseLBS def (BL.fromStrict bin) of
Left err -> Left err
Right doc ->
let cursor = fromDocument doc
in Right $ pure cursor
>>= element "stat"
>>= child
>>= checkName ( == "file" )
>>= \cur -> case (map (\a -> attribute a cur) ["type","name","size","md5","mtime"]) of
["file"]:[name]:[size]:[md5]:[mtime]:_ -> [File name (read $ T.unpack size) md5 (read $ T.unpack mtime)]
["dir"]:[name]:_ -> [Dir name]
["symlink"]:[name]:_ -> [Symlink name]
_ -> []
mkReq :: MonadUnliftIO m => Auth -> ByteString -> ByteString -> Action -> m Request
mkReq auth method path action = do
let path' = "/" <> BC.pack (show (authCpCode auth)) <> "/" <> path
initReq <- liftIO $ parseRequest $ BC.unpack $ method <> " "
<> (if authSsl auth then "https" else "http")
<> "://" <> (T.encodeUtf8 (authHostname auth))
<> path'
ut <- liftIO $ (getUnixTime >>= return.utSeconds)
uid <- liftIO (randomIO >>= return.(\v -> v `mod` 10000))
return $ setRequestHeaders (authHeaders ut uid (authKeyName auth) path' action (authKey auth)) initReq
download :: MonadUnliftIO m => Auth -> NetStoragePath -> ((Response () -> ConduitM ByteString Void m a)) -> m a
download auth path fn = do
req <- mkReq auth "GET" path "version=1&action=download"
httpSink req fn
dir :: MonadUnliftIO m => Auth -> NetStoragePath -> m (Either SomeException [Contents])
dir auth path = do
req <- mkReq auth "GET" path "version=1&action=dir&format=xml"
res <- httpBS req
return $ parseContents $ responseBody res
stat :: MonadUnliftIO m => Auth -> NetStoragePath -> m (Either SomeException [Contents])
stat auth path = do
req <- mkReq auth "GET" path "version=1&action=stat&format=xml"
res <- httpBS req
return $ parseContents $ responseBody res
delete :: MonadUnliftIO m => Auth -> NetStoragePath -> m (Response ByteString)
delete auth path = do
req <- mkReq auth "POST" path "version=1&action=delete"
httpBS req
upload :: MonadUnliftIO m => Auth -> NetStoragePath -> Int64 -> (ConduitM () ByteString IO ()) -> m (Response ByteString)
upload auth path size fn = do
initReq <- mkReq auth "PUT" path "version=1&action=upload&upload-type=binary"
let req = setRequestBodySource size fn initReq
httpBS req