diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for hsakamai + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 () + + diff --git a/app/PurgeMain.hs b/app/PurgeMain.hs new file mode 100644 --- /dev/null +++ b/app/PurgeMain.hs @@ -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 () + + diff --git a/hsakamai.cabal b/hsakamai.cabal new file mode 100644 --- /dev/null +++ b/hsakamai.cabal @@ -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 +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 diff --git a/src/Akamai/Edgegrid.hs b/src/Akamai/Edgegrid.hs new file mode 100644 --- /dev/null +++ b/src/Akamai/Edgegrid.hs @@ -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 + diff --git a/src/Akamai/NetStorage.hs b/src/Akamai/NetStorage.hs new file mode 100644 --- /dev/null +++ b/src/Akamai/NetStorage.hs @@ -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 "" +-- Right [] +-- >>> parseContents "" +-- 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 diff --git a/src/Akamai/Purge.hs b/src/Akamai/Purge.hs new file mode 100644 --- /dev/null +++ b/src/Akamai/Purge.hs @@ -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 diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,7 @@ +import Test.DocTest +main = doctest [ + "-isrc" + , "-XOverloadedStrings" + , "src/Akamai/NetStorage.hs" + , "src/Akamai/Edgegrid.hs" + ]