hsakamai (empty) → 0.1.0.0

raw patch · 11 files changed

+879/−0 lines, 11 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, case-insensitive, conduit, conduit-extra, cryptonite, doctest, hsakamai, http-client, http-conduit, http-types, memory, optparse-applicative, random, text, unix, unix-time, uuid, xml-conduit, yaml

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +80/−0
• Setup.hs +2/−0
• app/Main.hs +136/−0
• app/PurgeMain.hs +97/−0
• hsakamai.cabal +114/−0
• src/Akamai/Edgegrid.hs +162/−0
• src/Akamai/NetStorage.hs +174/−0
• src/Akamai/Purge.hs +74/−0
• test/doctests.hs +7/−0

@@ -0,0 +1,3 @@+# Changelog for hsakamai++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Junji Hashimoto (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Junji Hashimoto nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,80 @@+# hsakamai++[![Hackage version](https://img.shields.io/hackage/v/hsakamai.svg?style=flat)](https://hackage.haskell.org/package/hsakamai)  [![Build Status](https://travis-ci.org/junjihashimoto/hsakamai.png?branch=master)](https://travis-ci.org/junjihashimoto/hsakamai)++Akamai API for Haskell.++# Install++```+$ stack install+```++# Usage for Netstorage++Put ```netstorage.yml``` in a local directory.+The format is below.++```+$ cat > netstorage.yml+hostname: hostname-of-netstorage+key: secret-key+keyname: keyname+cpcode: cpcode+ssl: false+```+Next use ```netstorage``` command.++```+$ netstorage --help+Usage: netstorage COMMAND++Available options:+-h,--help                Show this help text++Available commands:+download                 download+upload                   upload+dir                      dir+stat                     stat+delete                   delete+config                   config+```++# Usage for Fast-Purge++Put ```edgegrid.yml``` in a local directory.+The format is below.++```+$ cat > edgegrid.yml+clientsecret: xx+hostname: xx+accesstoken: xx+clienttoken: xx+```++Next use ```purge``` command.++```+$ purge --help+Usage: purge COMMAND++Available options:+-h,--help                Show this help text++Available commands:+invalidate-url           invalidate-url+invalidate-cpcode        invalidate-cpcode+invalidate-tag           invalidate-tag+delete-url               delete-url+delete-cpcode            delete-cpcode+delete-tag               delete-tag+config                   config+$ purge invalidate-url Production https://foo.com+```++# References++* https://learn.akamai.com/en-us/webhelp/netstorage/netstorage-http-api-developer-guide/GUID-22B017EE-DD73-4099-B96D-B5FD91E1ED98.html+* https://developer.akamai.com/legacy/introduction/Client_Auth.html

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Akamai.NetStorage+import Options.Applicative+import Data.Yaml (decodeFileEither,encode)+import qualified Data.ByteString as B+import Data.Conduit.Binary+import Data.String (fromString)+import qualified System.Posix as S+++data Command+  = Download String String+  | Upload String String+  | Ls String+  | Stat String+  | Delete String+  | Config+  deriving (Eq, Show)++downloadCmd :: Parser Command+downloadCmd = Download <$> (argument str (metavar "NetStoragePath")) <*> (argument str (metavar "Local"))++uploadCmd :: Parser Command+uploadCmd = Upload <$> (argument str (metavar "Local")) <*> (argument str (metavar "NetStoragePath"))++dirCmd :: Parser Command+dirCmd = Ls <$> (argument str (metavar "NetStoragePath"))++statCmd :: Parser Command+statCmd = Stat <$> (argument str (metavar "NetStoragePath"))++deleteCmd :: Parser Command+deleteCmd = Delete <$> (argument str (metavar "NetStoragePath"))++configCmd :: Parser Command+configCmd = pure Config++getFileSize :: String -> IO S.FileOffset+getFileSize path = do+  stat' <- S.getFileStatus path+  return (S.fileSize stat')++readAuth :: IO (Maybe Auth)+readAuth = do+  v <- decodeFileEither "netstorage.yml"+  case v of+    Right v' -> return $ Just v'+    Left err -> do+      print err+      return Nothing++run :: Command -> IO Bool+run (Download from to) = do+  mauth <- readAuth+  case mauth of+    Just auth -> do+      withSinkFile (fromString to) $ \sink -> do+        download auth (fromString from) $ \_ -> do+          sink+      return True+    Nothing  -> return False++run (Upload from to) = do+  mauth <- readAuth+  case mauth of+    Just auth -> do+      size <- getFileSize from+      _ <- withSourceFile (fromString from) $ \src -> do+        upload auth (fromString to) (fromIntegral size) src+      return True+    Nothing  -> return False++run (Ls path) = do+  mauth <- readAuth+  case mauth of+    Just auth -> do+      v <- dir auth (fromString path)+      case v of+        Right contents -> do+          B.putStr $ encode contents+          return True+        Left err -> do+          print err+          return False+    Nothing  -> return False++run (Stat path) = do+  mauth <- readAuth+  case mauth of+    Just auth -> do+      v <- stat auth (fromString path)+      case v of+        Right contents -> do+          B.putStr $ encode contents+          return True+        Left err -> do+          print err+          return False+    Nothing  -> return False++run (Delete path) = do+  mauth <- readAuth+  case mauth of+    Just auth -> do+      v <- delete auth (fromString path)+      print v+      return True+    Nothing  -> return False++run (Config) = do+  B.putStr $ encode $ Auth "host" "keyname" "key" 123 True+  return True++commands :: Parser Command+commands = subparser+           (  command "download"         (info downloadCmd    (progDesc "download"))+           <> command "upload"           (info uploadCmd      (progDesc "upload"))+           <> command "dir"              (info dirCmd         (progDesc "dir"))+           <> command "stat"             (info statCmd        (progDesc "stat"))+           <> command "delete"           (info deleteCmd      (progDesc "delete"))+           <> command "config"           (info configCmd      (progDesc "config"))+           )++opts :: ParserInfo Command+opts = info (commands <**> helper) idm++main :: IO ()+main = do+  cmd <- execParser opts+  _ <- run cmd+  return ()++

@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Akamai.Edgegrid+import Akamai.Purge+import Options.Applicative+import Data.Yaml (decodeFileEither,encode)+import qualified Data.ByteString as B+import qualified Data.Text as T+import Network.HTTP.Client (responseBody)+++data Command+  = InvalidateUrl Network String+  | InvalidateCpCode Network Int+  | InvalidateTag Network String+  | DeleteUrl Network String+  | DeleteCpCode Network Int+  | DeleteTag Network String+  | Config+  deriving (Eq, Show)++invalidateUrlCmd :: Parser Command+invalidateUrlCmd = InvalidateUrl <$> (argument auto (metavar "network")) <*> (argument str (metavar "url"))++invalidateCpCodeCmd :: Parser Command+invalidateCpCodeCmd = InvalidateCpCode <$> (argument auto (metavar "network")) <*> (argument auto (metavar "cpcode"))++invalidateTagCmd :: Parser Command+invalidateTagCmd = InvalidateTag <$> (argument auto (metavar "network")) <*> (argument str (metavar "tag"))++deleteUrlCmd :: Parser Command+deleteUrlCmd = DeleteUrl <$> (argument auto (metavar "network")) <*> (argument str (metavar "url"))++deleteCpCodeCmd :: Parser Command+deleteCpCodeCmd = DeleteCpCode <$> (argument auto (metavar "network")) <*> (argument auto (metavar "cpcode"))++deleteTagCmd :: Parser Command+deleteTagCmd = DeleteTag <$> (argument auto (metavar "network")) <*> (argument str (metavar "tag"))++configCmd :: Parser Command+configCmd = pure Config++readAuth :: IO (Maybe Auth)+readAuth = do+  v <- decodeFileEither "edgegrid.yml"+  case v of+    Right v' -> return $ Just v'+    Left err -> do+      print err+      return Nothing++run :: Command -> IO Bool+run cmd = do+  case cmd of+    Config -> do+      B.putStr $ encode $ Auth "host" "access-token" "client-token" "client-secret"+      return True+    InvalidateUrl network url -> run' invalidateByUrl network [T.pack url]+    InvalidateCpCode network cpcode -> run' invalidateByCpCode network [cpcode]+    InvalidateTag network tag -> run' invalidateByCacheTag network [T.pack tag]+    DeleteUrl network url -> run' deleteByUrl network [T.pack url]+    DeleteCpCode network cpcode -> run' deleteByCpCode network [cpcode]+    DeleteTag network tag -> run' deleteByCacheTag network [T.pack tag]+  where+    run' fn network arg = do+      mauth <- readAuth+      case mauth of+        Just auth -> do+          v <- fn auth network arg+          B.putStr $ encode $ responseBody v+          return True+        Nothing  -> return False+++commands :: Parser Command+commands = subparser+           (  command "invalidate-url"    (info invalidateUrlCmd    (progDesc "invalidate-url"))+           <> command "invalidate-cpcode" (info invalidateCpCodeCmd (progDesc "invalidate-cpcode"))+           <> command "invalidate-tag"    (info invalidateTagCmd    (progDesc "invalidate-tag"))+           <> command "delete-url"        (info deleteUrlCmd        (progDesc "delete-url"))+           <> command "delete-cpcode"     (info deleteCpCodeCmd     (progDesc "delete-cpcode"))+           <> command "delete-tag"        (info deleteTagCmd        (progDesc "delete-tag"))+           <> command "config"            (info configCmd           (progDesc "config"))+           )++opts :: ParserInfo Command+opts = info (commands <**> helper) idm++main :: IO ()+main = do+  cmd <- execParser opts+  _ <- run cmd+  return ()++

@@ -0,0 +1,114 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 6044931085d4715cad738d927656fc833fd07a6ffe0e2856a4a27970824059c0++name:           hsakamai+version:        0.1.0.0+synopsis:       Akamai API(Edgegrid and Netstorage)+description:    Please see the README on GitHub at <https://github.com/githubuser/hsakamai#readme>+category:       Web+homepage:       https://github.com/junjihashimoto/hsakamai#readme+bug-reports:    https://github.com/junjihashimoto/hsakamai/issues+author:         Junji Hashimoto+maintainer:     junji.hashimoto@gmail.com+copyright:      2019 Junji Hashimoto+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/junjihashimoto/hsakamai++library+  exposed-modules:+      Akamai.Edgegrid+      Akamai.NetStorage+      Akamai.Purge+  other-modules:+      Paths_hsakamai+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , case-insensitive+    , conduit+    , cryptonite+    , http-client+    , http-conduit+    , http-types+    , memory+    , random+    , text+    , unix-time+    , uuid+    , xml-conduit+  default-language: Haskell2010++executable purge+  main-is: PurgeMain.hs+  other-modules:+      Main+      Paths_hsakamai+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , case-insensitive+    , conduit+    , conduit-extra+    , cryptonite+    , hsakamai+    , http-client+    , http-conduit+    , http-types+    , memory+    , optparse-applicative+    , random+    , text+    , unix+    , unix-time+    , uuid+    , xml-conduit+    , yaml+  default-language: Haskell2010++test-suite doctest+  type: exitcode-stdio-1.0+  main-is: doctests.hs+  other-modules:+      Paths_hsakamai+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , case-insensitive+    , conduit+    , cryptonite+    , doctest+    , hsakamai+    , http-client+    , http-conduit+    , http-types+    , memory+    , random+    , text+    , unix-time+    , uuid+    , xml-conduit+  default-language: Haskell2010

@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Akamai.Edgegrid+  ( Auth(..)+  , mkReq+  , mkJsonReq+  ) where++import Crypto.Hash.Algorithms+import Crypto.MAC.HMAC+import Crypto.Hash+import Data.UUID.V4 (nextRandom)+import Data.UUID (toASCIIBytes)+import Data.CaseInsensitive (original)++import Data.Aeson+import Data.Aeson.TH+import Data.ByteArray.Encoding (convertToBase, Base (Base64))+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import Data.Char (toLower)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.UnixTime hiding (UnixTime)+import Network.HTTP.Client.Conduit (RequestBody(..))+import Network.HTTP.Simple+import Network.HTTP.Types (hAuthorization, HeaderName)++type Message = ByteString+type AuthSign = ByteString+type Nonce = ByteString+type Method = ByteString+type PathWithQuery = ByteString+type CanonicalizedRequestHeaders = [(HeaderName,ByteString)]+type Body = ByteString++data Auth = Auth+  { authHostname :: Text+  , authAccessToken :: Text+  , authClientToken :: Text+  , authClientSecret :: Text+  } deriving (Show,Read,Eq)++$(deriveJSON defaultOptions{fieldLabelModifier = (map toLower) . (drop 4)} ''Auth)++-- | dataToSign+--+-- >>> base_url = "akaa-baseurl-xxxxxxxxxxx-xxxxxxxxxxxxx.luna.akamaiapis.net"+-- >>> access_token = "akab-access-token-xxx-xxxxxxxxxxxxxxxx"+-- >>> client_token = "akab-client-token-xxx-xxxxxxxxxxxxxxxx"+-- >>> client_secret = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx="+-- >>> nonce = "nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx"+-- >>> timestamp = "20140321T19:34:21+0000"+-- >>> dataToSign (Auth base_url access_token client_token client_secret) "GET" "/" [] "" "20140321T19:34:21+0000" "nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx"+-- "GET\thttps\takaa-baseurl-xxxxxxxxxxx-xxxxxxxxxxxxx.luna.akamaiapis.net\t/\t\t\tEG1-HMAC-SHA256 client_token=akab-client-token-xxx-xxxxxxxxxxxxxxxx;access_token=akab-access-token-xxx-xxxxxxxxxxxxxxxx;timestamp=20140321T19:34:21+0000;nonce=nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx;"++-- "EG1-HMAC-SHA256 client_token=akab-client-token-xxx-xxxxxxxxxxxxxxxx;access_token=akab-access-token-xxx-xxxxxxxxxxxxxxxx;timestamp=20140321T19:34:21+0000;nonce=nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx;signature=hXm4iCxtpN22m4cbZb4lVLW5rhX8Ca82vCFqXzSTPe4="+dataToSign :: Auth+           -> Method+           -> PathWithQuery+           -> CanonicalizedRequestHeaders+           -> Body+           -> ByteString+           -> Nonce+           -> ByteString+dataToSign auth method pathWithQuery creqHeaders body timeStamp nonce =+  method <> "\t" <>+  "https" <> "\t" <>+  T.encodeUtf8 (authHostname auth) <> "\t" <>+  pathWithQuery <> "\t" <>+  (B.intercalate "\t" $ map (\(k,v) -> original k <> ":" <> v) creqHeaders) <> "\t" <>+  (if body == "" then "" else contentHash body) <> "\t" <>+  "EG1-HMAC-SHA256 " <>+  "client_token=" <> T.encodeUtf8 (authClientToken auth) <> ";" <>+  "access_token=" <> T.encodeUtf8 (authAccessToken auth) <> ";" <>+  "timestamp=" <> timeStamp <> ";" <>+  "nonce=" <> nonce <> ";"++-- | authHeader+--+-- >>> authSign "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx=" "20140321T19:34:21+0000"+-- "znsRMDBRqTXGJ7Ojip3/h2FGPu3LuoMYWgv9PKEnE/o="+authSign :: ByteString -> Message -> AuthSign+authSign key msg = convertToBase Base64 $ (hmac key msg :: HMAC SHA256)++contentHash :: Message -> ByteString+contentHash msg = convertToBase Base64 $ (hash msg :: Digest SHA256)++-- | authHeader+--+-- >>> base_url = "akaa-baseurl-xxxxxxxxxxx-xxxxxxxxxxxxx.luna.akamaiapis.net"+-- >>> access_token = "akab-access-token-xxx-xxxxxxxxxxxxxxxx"+-- >>> client_token = "akab-client-token-xxx-xxxxxxxxxxxxxxxx"+-- >>> client_secret = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx="+-- >>> nonce = "nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx"+-- >>> timestamp = "20140321T19:34:21+0000"+-- >>> authHeader (Auth base_url access_token client_token client_secret) "GET" "/" [] "" "20140321T19:34:21+0000" "nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx"+-- "EG1-HMAC-SHA256 client_token=akab-client-token-xxx-xxxxxxxxxxxxxxxx;access_token=akab-access-token-xxx-xxxxxxxxxxxxxxxx;timestamp=20140321T19:34:21+0000;nonce=nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx;signature=tL+y4hxyHxgWVD30X3pWnGKHcPzmrIF+LThiAOhMxYU="+-- >>> authHeader (Auth base_url access_token client_token client_secret) "GET" "/testapi/v1/t1?p1=1&p2=2" [] "" "20140321T19:34:21+0000" "nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx"+-- "EG1-HMAC-SHA256 client_token=akab-client-token-xxx-xxxxxxxxxxxxxxxx;access_token=akab-access-token-xxx-xxxxxxxxxxxxxxxx;timestamp=20140321T19:34:21+0000;nonce=nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx;signature=hKDH1UlnQySSHjvIcZpDMbQHihTQ0XyVAKZaApabdeA="+-- >>> authHeader (Auth base_url access_token client_token client_secret) "POST" "/testapi/v1/t3" [] "datadatadatadatadatadatadatadata" "20140321T19:34:21+0000" "nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx"+-- "EG1-HMAC-SHA256 client_token=akab-client-token-xxx-xxxxxxxxxxxxxxxx;access_token=akab-access-token-xxx-xxxxxxxxxxxxxxxx;timestamp=20140321T19:34:21+0000;nonce=nonce-xx-xxxx-xxxx-xxxx-xxxxxxxxxxxx;signature=hXm4iCxtpN22m4cbZb4lVLW5rhX8Ca82vCFqXzSTPe4="+authHeader :: Auth+           -> Method+           -> PathWithQuery+           -> CanonicalizedRequestHeaders+           -> Body+           -> ByteString+           -> Nonce+           -> ByteString+authHeader auth method pathWithQuery creqHeaders body timeStamp nonce =+  "EG1-HMAC-SHA256 " <>+  "client_token=" <> T.encodeUtf8 (authClientToken auth) <> ";" <>+  "access_token=" <> T.encodeUtf8 (authAccessToken auth) <> ";" <>+  "timestamp=" <> timeStamp <> ";" <>+  "nonce=" <> nonce <> ";" <>+  "signature=" <> signature+  where+    signature = authSign signingKey (dataToSign auth method pathWithQuery creqHeaders body' timeStamp nonce)+    signingKey = authSign (T.encodeUtf8 (authClientSecret auth)) timeStamp+    body' = B.take 131072 body++mkReq :: Auth+      -> Method+      -> PathWithQuery+      -> CanonicalizedRequestHeaders+      -> Body+      -> IO Request+mkReq auth method pathWithQuery creqHeaders body = do+  initReq <- parseRequest $ BC.unpack $ method <> " "+    <> "https"+    <> "://" <> (T.encodeUtf8 (authHostname auth))+    <> pathWithQuery+  timeStamp <- (getUnixTime >>= return.(formatUnixTimeGMT "%Y%m%dT%H:%M:%S%z"))+  uuid <- (nextRandom >>= return.toASCIIBytes)+  return $+    setRequestBody (RequestBodyBS body) $+    setRequestHeaders ((hAuthorization,authHeader auth method pathWithQuery creqHeaders body timeStamp uuid):creqHeaders) initReq++mkJsonReq :: ToJSON a+          => Auth+          -> Method+          -> PathWithQuery+          -> CanonicalizedRequestHeaders+          -> a+          -> IO Request+mkJsonReq auth method pathWithQuery creqHeaders body = do+  initReq <- parseRequest $ BC.unpack $ method <> " "+    <> "https"+    <> "://" <> (T.encodeUtf8 (authHostname auth))+    <> pathWithQuery+  timeStamp <- (getUnixTime >>= return.(formatUnixTimeGMT "%Y%m%dT%H:%M:%S%z"))+  uuid <- (nextRandom >>= return.toASCIIBytes)+  return $+    setRequestHeader "Content-Type" ["application/json"] $+    setRequestBodyJSON body $+    setRequestHeaders ((hAuthorization,authHeader auth method pathWithQuery creqHeaders (BL.toStrict (encode body)) timeStamp uuid):creqHeaders) initReq+

@@ -0,0 +1,174 @@+{-# 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 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++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+--+-- >>> authData 123 456 "key"+-- "5, 0.0.0.0, 0.0.0.0, 123, 456, key"+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+--+-- >>> signString "path" "version=1&action=download"+-- "path\nx-akamai-acs-action:version=1&action=download\n"+signString :: NetStoragePath -> Action -> SignString+signString path action = path <> "\n" <> "x-akamai-acs-action:" <> action <> "\n"+++-- | authSign+-- >>> authSign "abcdefghij" "5, 0.0.0.0, 0.0.0.0, 1280000000, 382644692, UploadAccountMedia/123456/files_baseball/sweep.m4a\nx-akamai-acs-action:version=1&action=upload&md5=0123456789abcdef0123456789abcdef&mtime=1260000000\n"+-- "yh1MXm/rv7RKZhfKlTuSUBV69Acph5IyOWCU0/nFjms="+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+--+-- >>> parseContents "<stat></stat>"+-- Right []+-- >>> parseContents "<stat><file type=\"file\" name=\"[CP Code]/File1.ext\" size=\"3\" md5=\"[HASH]\" mtime=\"1524068379\"/><file type=\"dir\"  name=\"[CP Code]/explicitdir1/\"/><file type=\"symlink\" name=\"[CP Code]/explicitdir2/link1\"/></stat>"+-- Right [File {fileName = "[CP Code]/File1.ext", fileSize = 3, fileMd5 = "[HASH]", fileMtime = 1524068379},Dir {dirName = "[CP Code]/explicitdir1/"},Symlink {symlinkName = "[CP Code]/explicitdir2/link1"}]+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 :: Auth -> ByteString -> ByteString -> Action -> IO Request+mkReq auth method path action = do+  let path' = "/" <> BC.pack (show (authCpCode auth)) <> "/" <> path+  initReq <- parseRequest $ BC.unpack $ method <> " "+    <> (if authSsl auth then "https" else "http")+    <> "://" <> (T.encodeUtf8 (authHostname auth))+    <> path'+  ut <- (getUnixTime >>= return.utSeconds)+  uid <- (randomIO >>= return.(\v -> v `mod` 10000))+  return $ setRequestHeaders (authHeaders ut uid (authKeyName auth) path' action (authKey auth)) initReq++download :: Auth -> NetStoragePath -> ((Response () -> ConduitM ByteString Void IO a)) -> IO a+download auth path fn = do+  req <- mkReq auth "GET" path "version=1&action=download"+  httpSink req fn++dir :: Auth -> NetStoragePath -> IO (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 :: Auth -> NetStoragePath -> IO (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 :: Auth -> NetStoragePath -> IO (Response ByteString)+delete auth path = do+  req <- mkReq auth "POST" path "version=1&action=delete"+  httpBS req++upload :: Auth -> NetStoragePath -> Int64 -> (ConduitM () ByteString IO ()) -> IO (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

@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Akamai.Purge+  ( Network(..)+  , invalidateByUrl+  , invalidateByCpCode+  , invalidateByCacheTag+  , deleteByUrl+  , deleteByCpCode+  , deleteByCacheTag+  ) where++import Akamai.Edgegrid+import Data.Aeson+import Data.Aeson.TH+import Data.Text (Text)+import Network.HTTP.Simple++data Network = Production | Staging deriving (Show,Read,Eq)++data PurgeResponse = PurgeResponse+  { httpStatus :: Int+  , estimatedSeconds :: Int+  , purgeId :: Text+  , supportId :: Text+  , detail :: Text+  } deriving (Show,Read,Eq)++$(deriveJSON defaultOptions ''PurgeResponse)++invalidateByUrl :: Auth -> Network -> [Text] -> IO (Response PurgeResponse)+invalidateByUrl auth network urls = do+  let env = if network == Production then "production" else "staging"+  req <- mkJsonReq auth "POST" ("/ccu/v3/invalidate/url/" <> env) [] $+    object ["objects" .= urls]+  httpJSON req+++invalidateByCpCode :: Auth -> Network -> [Int] -> IO (Response PurgeResponse)+invalidateByCpCode auth network cpcodes = do+  let env = if network == Production then "production" else "staging"+  req <- mkJsonReq auth "POST" ("/ccu/v3/invalidate/cpcode/" <> env) [] $+    object ["objects" .= (map (\v -> Number (fromIntegral v)) cpcodes)]+  httpJSON req++invalidateByCacheTag ::  Auth -> Network -> [Text] -> IO (Response PurgeResponse)+invalidateByCacheTag auth network tags = do+  let env = if network == Production then "production" else "staging"+  req <- mkJsonReq auth "POST" ("/ccu/v3/invalidate/tag/" <> env) [] $+    object ["objects" .= tags]+  httpJSON req++deleteByUrl :: Auth -> Network -> [Text] -> IO (Response PurgeResponse)+deleteByUrl auth network urls = do+  let env = if network == Production then "production" else "staging"+  req <- mkJsonReq auth "POST" ("/ccu/v3/delete/url/" <> env) [] $+    object ["objects" .= urls]+  httpJSON req++deleteByCpCode :: Auth -> Network -> [Int] -> IO (Response PurgeResponse)+deleteByCpCode auth network cpcodes = do+  let env = if network == Production then "production" else "staging"+  req <- mkJsonReq auth "POST" ("/ccu/v3/delete/cpcode/" <> env) [] $+    object ["objects" .= (map (\v -> Number (fromIntegral v)) cpcodes)]+  httpJSON req++deleteByCacheTag :: Auth -> Network -> [Text] -> IO (Response PurgeResponse)+deleteByCacheTag auth network tags = do+  let env = if network == Production then "production" else "staging"+  req <- mkJsonReq auth "POST" ("/ccu/v3/delete/tag/" <> env) [] $+    object ["objects" .= tags]+  httpJSON req

@@ -0,0 +1,7 @@+import Test.DocTest+main = doctest [+    "-isrc"+  , "-XOverloadedStrings"+  , "src/Akamai/NetStorage.hs"+  , "src/Akamai/Edgegrid.hs"+  ]