diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +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 Author name here 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/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/fastly.cabal b/fastly.cabal new file mode 100644 --- /dev/null +++ b/fastly.cabal @@ -0,0 +1,48 @@ +name: fastly +version: 0.1.0.0 +synopsis: A highly experimental Fastly API client. +description: Please see README.md +homepage: https://github.com/iand675/fastly#readme +license: BSD3 +license-file: LICENSE +author: Ian Duncan +maintainer: ian@iankduncan.com +copyright: 2018 Ian Duncan +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Network.Fastly + build-depends: base >= 4.7 && < 5, + http-client, + http-client-tls, + http-types, + text, + aeson, + bytestring, + unordered-containers, + iproute, + bytestring-lexing, + mtl, + thyme, + old-locale, + wai + default-language: Haskell2010 + +test-suite fastly-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , fastly + , text + , hspec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/iand675/fastly diff --git a/src/Network/Fastly.hs b/src/Network/Fastly.hs new file mode 100644 --- /dev/null +++ b/src/Network/Fastly.hs @@ -0,0 +1,979 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | + +Highly unstable implementation of the Fastly API. Contributions are welcome. + +'purge', 'purgeKey', and 'purgeAll' are reasonably well tested. + +-} +module Network.Fastly + ( FastlyAuth(..) + , Username(..) + , Password(..) + , FastlyClient + , fastlyClient + , fastly + , FastlyResponse(..) + -- Account + {- + -} + -- Configuration + {- + , listBackends + , getBackend + , createBackend + , updateBackend + , deleteBackend + -} + {- + , listCacheSettings + , getCacheSettings + , createCacheSettings + , updateCacheSettings + , deleteCacheSettings + -} + {- + , listConditions + , getCondition + , createCondition + , updateCondition + , deleteCondition + -} + -- Dictionaries + , listDictionaries + , getDictionary + , createDictionary + , updateDictionary + , deleteDictionary + -- Dictionary items + , listDictionaryItems + , getDictionaryItem + , createDictionaryItem + , upsertDictionaryItem + , updateDictionaryItem + , batchEditDictionaryItems + , deleteDictionaryItem + {- + , getDiff + -} + {- + , listDirectors + , getDirector + , createDirector + , updateDirector + , deleteDirector + -} + {- + , getDirectorBackendRelationship + , establishDirectorBackendRelationship + , deleteDirectorBackendRelationship + -} + , checkDomainRecords + , checkDomainRecord + , listDomains + , getDomain + , createDomain + {- + , updateDomain + , deleteDomain + -} + , listGzipConfigurations + , getGzipConfiguration + {- + , createGzipConfiguration + , updateGzipConfiguration + -} + , deleteGzipConfiguration + {- + , listHeaders + , getHeader + , createHeader + , updateHeader + , deleteHeader + -} + {- + , listHealthchecks + , getHealthcheck + , createHealthcheck + , updateHealthcheck + , deleteHealthcheck + -} + {- + , getRequestSettingsObject + , listRequestSettingsObjects + , createRequestSettingsObject + , deleteRequestSettingsObject + , updateRequestSettingsObject + -} + {- + , getResponseObject + , listResponseObjects + , createResponseObject + , deleteResponseObject + , updateResponseObject + -} + {- + -} + , listServices + , getServiceDetails + , getServiceByName + , getService + , ServiceId(..) + , Service(..) + {- + , createService + , deleteService + , updateService + , listServiceDomains + -} + {- + , getServiceSettings + , updateServiceSettings + -} + {- + , getServiceStats + -} + {- + , getVcls + , getBoilerplateVcl + , getVcl + , getSyntaxHighlightedVcl + , downloadVcl -- ???? + , getGeneratedVcl + , getSyntaxHighlightedGeneratedVcl + , uploadVcl + , deleteVcl + , setMainVcl + , updateVcl + -} + {- + , getServiceVersion + , createServiceVersion + , listServiceVersions + , updateServiceVersion + , activateServiceVersion + , deactivateServiceVersion + , cloneServiceVersion + , validateServiceVersion + , lockServiceVersion + -} + {- + , getWordpressConfiguration + , listWordpressConfigurations + , createWordpressConfiguration + , deleteWordpressConfiguration + , updateWordpressConfiguration + -} + -- Purging + , PurgeMode(..) + , SurrogateKey(..) + , purge + , purgeKey + , purgeAll + , PurgeResult(..) + , PurgeAllResult(..) + -- Historical Stats + + -- Remote Logging + + -- Miscellaneous + , edgeCheck + , CacheStatus(..) + , CacheStatusRequest(..) + , CacheStatusResponse(..) + , publicIpList + , Addresses(..) + ) where +import Control.Applicative +import Control.Exception +import Control.Monad.Except +import Data.Aeson +import Data.Aeson.Types +import Data.IP +import Data.Monoid +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lex.Integral (readDecimal_) +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Thyme.Clock (UTCTime) +import Data.Thyme.Format +import Data.HashMap.Strict (HashMap) +import GHC.Generics +import Network.HTTP.Client as C +import qualified Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.HTTP.Types +import System.IO.Unsafe +import System.Locale + +data FastlyResponse a = FastlyResponse + { fastlyResponseRateLimitRemaining :: Int + , fastlyResponseRateLimitReset :: Int -- ^ UTC epoch seconds + , fastlyResponseValue :: a + } deriving (Show) + +data FastlyClient = FastlyClient + { fastlyClientBaseRequest :: Request + } + +data FastlyError = InvalidOrMissingRateLimitData + | JsonError String (Maybe Value) + | InvalidUrl String + deriving (Show, Eq) + +instance Exception FastlyError + +pedanticDecode :: (Monad m, FromJSON a) => Response ByteString -> m (Either FastlyError a) +pedanticDecode r = return $ case eitherDecode $ responseBody r of + Right r -> Right r + Left e -> case eitherDecode $ responseBody r of + Left je -> Left $ JsonError je Nothing + Right j -> Left $ JsonError e (Just j) + +readFromResponse :: Response a -> (Response a -> Either FastlyError b) -> Either FastlyError (FastlyResponse b) +readFromResponse r f = do + case details of + Nothing -> Left InvalidOrMissingRateLimitData + Just (rem, res) -> do + x <- f r + return $ FastlyResponse rem res x + where + hs = responseHeaders r + details = do + remBs <- lookup "Fastly-RateLimit-Remaining" hs + resBs <- lookup "Fastly-RateLimit-Reset" hs + return (readDecimal_ remBs, readDecimal_ resBs) + +fastlyRootRequest :: Request +fastlyRootRequest = parseRequest_ "https://api.fastly.com/" + +newtype Username = Username Text +newtype Password = Password Text + +data FastlyAuth = AuthToken Text + | Login Username Password + +fastlyClient :: FastlyAuth -> IO FastlyClient +fastlyClient (AuthToken t) = do + return $ + FastlyClient + (fastlyRootRequest + { requestHeaders = + ("Fastly-Key", encodeUtf8 t) : + ("Accept", "application/json") : requestHeaders fastlyRootRequest + }) +fastlyClient (Login (Username u) (Password p)) = do + error "Login not supported yet" + {- + m <- newManager + let req' = fastlyRootRequest { cookieJar = Just mempty + , path = "/login" + } + let reqEditor r = case cookieJar r of + resp <- httpNoBody req'' m + reqRef <- newIORef $ fastlyRootRequest { cookieJar = responseCookieJar resp } + return $ FastlyClient m reqRef + -} + +type FastlyM a = ExceptT FastlyError IO a + +fastly :: Text -> (FastlyClient -> FastlyM a) -> IO (Either FastlyError a) +fastly t f = do + c <- fastlyClient $ AuthToken t + let (ExceptT m) = f c + m + + +jsonOpts :: Int -> Options +jsonOpts x = defaultOptions { fieldLabelModifier = camelTo2 '_' . drop x } + +get :: FromJSON a => FastlyClient -> (Request -> Request) -> FastlyM a +get c f = ExceptT $ do + m <- getGlobalManager + r <- httpLbs ((f $ fastlyClientBaseRequest c) { method = "GET" }) m + pedanticDecode r + +post :: FromJSON a => FastlyClient -> (Request -> Request) -> FastlyM a +post c f = ExceptT $ do + m <- getGlobalManager + r <- httpLbs ((f $ fastlyClientBaseRequest c) { method = "POST" }) m + pedanticDecode r + +put :: FromJSON a => FastlyClient -> (Request -> Request) -> FastlyM a +put c f = ExceptT $ do + m <- getGlobalManager + r <- httpLbs ((f $ fastlyClientBaseRequest c) { method = "PUT" }) m + pedanticDecode r + +delete :: FromJSON a => FastlyClient -> (Request -> Request) -> FastlyM a +delete c f = ExceptT $ do + m <- getGlobalManager + r <- httpLbs ((f $ fastlyClientBaseRequest c) { method = "DELETE" }) m + pedanticDecode r + +patch :: FromJSON a => FastlyClient -> (Request -> Request) -> FastlyM a +patch c f = ExceptT $ do + m <- getGlobalManager + r <- httpLbs ((f $ fastlyClientBaseRequest c) { method = "PATCH" }) m + pedanticDecode r + +newtype DictionaryId = DictionaryId Text + deriving (Show, ToJSON, FromJSON) + +data Dictionary = Dictionary + { dictionaryCreatedAt :: Timestamp + , dictionaryDeletedAt :: Maybe Timestamp + , dictionaryId :: DictionaryId + , dictionaryName :: Text + , dictionaryServiceId :: ServiceId + , dictionaryUpdatedAt :: Maybe Timestamp + , dictionaryVersion :: ServiceVersionNumber + } deriving (Show, Generic) + +instance ToJSON Dictionary where + toJSON = genericToJSON (jsonOpts 10) + +instance FromJSON Dictionary where + parseJSON = genericParseJSON (jsonOpts 10) + +listDictionaries :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> FastlyM [Dictionary] +listDictionaries c (ServiceId sid) (ServiceVersionNumber v) = get c $ \r -> + r { path = "/service/" <> encodeUtf8 sid <> "/version/" <> BS.pack (show v) <> "/dictionary" } + +getDictionary :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text -- ^ Dictionary name + -> FastlyM Dictionary +getDictionary c (ServiceId sid) (ServiceVersionNumber v) d = get c $ \r -> + r { path = "/service/" <> encodeUtf8 sid <> "/version/" <> BS.pack (show v) <> "/dictionary/" <> urlEncode False (encodeUtf8 d) } + +createDictionary :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text -- ^ Dictionary name + -> FastlyM Dictionary +createDictionary c (ServiceId sid) (ServiceVersionNumber v) d = post c $ \r -> urlEncodedBody [("name", encodeUtf8 d)] $ + r { path = "/service/" <> encodeUtf8 sid <> "/version/" <> BS.pack (show v) <> "/dictionary" + } + +updateDictionary :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text + -> Text + -> FastlyM Dictionary +updateDictionary c (ServiceId sid) (ServiceVersionNumber v) dOld dNew = put c $ \r -> urlEncodedBody [("name", encodeUtf8 dNew)] $ + r { path = "/service/" <> encodeUtf8 sid <> "/version/" <> BS.pack (show v) <> "/dictionary/" <> urlEncode False (encodeUtf8 dOld) } + + +data DeleteDictionaryResult = DeleteDictionaryResult + { deleteDictionaryResultStatus :: Text + } deriving (Show, Generic) + +instance ToJSON DeleteDictionaryResult where + toJSON = genericToJSON (jsonOpts 22) + +instance FromJSON DeleteDictionaryResult where + parseJSON = genericParseJSON (jsonOpts 22) + +deleteDictionary :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text -- ^ Dictionary name + -> FastlyM Dictionary +deleteDictionary c (ServiceId sid) (ServiceVersionNumber v) d = delete c $ \r -> + r { path = "/service/" <> encodeUtf8 sid <> "/version/" <> BS.pack (show v) <> "/dictionary/" <> urlEncode False (encodeUtf8 d) } + +data DictionaryItem = DictionaryItem + { dictionaryItemDictionaryId :: DictionaryId + , dictionaryItemServiceId :: ServiceId + , dictionaryItemItemKey :: Text + , dictionaryItemItemValue :: Text + , dictionaryItemCreatedAt :: Timestamp + , dictionaryItemUpdatedAt :: Timestamp + , dictionaryItemDeletedAt :: Maybe Timestamp + } deriving (Show, Generic) + +instance ToJSON DictionaryItem where + toJSON = genericToJSON (jsonOpts 14) + +instance FromJSON DictionaryItem where + parseJSON = genericParseJSON (jsonOpts 14) + +listDictionaryItems :: FastlyClient + -> ServiceId + -> DictionaryId + -> FastlyM [DictionaryItem] +listDictionaryItems c (ServiceId s) (DictionaryId d) = get c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/dictionary/" <> encodeUtf8 d <> "/items" } + +getDictionaryItem :: FastlyClient + -> ServiceId + -> DictionaryId + -> Text -- ^ Key + -> FastlyM DictionaryItem +getDictionaryItem c (ServiceId s) (DictionaryId d) k = get c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/dictionary/" <> encodeUtf8 d <> "/item/" <> urlEncode False (encodeUtf8 k)} + +createDictionaryItem :: FastlyClient + -> ServiceId + -> DictionaryId + -> Text -- ^ Key + -> Text -- ^ Value + -> FastlyM DictionaryItem +createDictionaryItem c (ServiceId s) (DictionaryId d) k v = post c $ \r -> urlEncodedBody [("item_key", encodeUtf8 k), ("item_value", encodeUtf8 v)] $ + r { requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : requestHeaders r + , path = "/service/" <> encodeUtf8 s <> "/dictionary/" <> encodeUtf8 d <> "/item" + } + +upsertDictionaryItem :: FastlyClient + -> ServiceId + -> DictionaryId + -> Text -- ^ Key + -> Text -- ^ Value + -> FastlyM DictionaryItem +upsertDictionaryItem c (ServiceId s) (DictionaryId d) k v = put c $ \r -> urlEncodedBody [("item_value", encodeUtf8 v)] $ + r { requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : requestHeaders r + , path = "/service/" <> encodeUtf8 s <> "/dictionary/" <> encodeUtf8 d <> "/item/" <> urlEncode False (encodeUtf8 k) + } + +updateDictionaryItem :: FastlyClient + -> ServiceId + -> DictionaryId + -> Text -- ^ Key + -> Text -- ^ Value + -> FastlyM DictionaryItem +updateDictionaryItem c (ServiceId s) (DictionaryId d) k v = put c $ \r -> urlEncodedBody [("item_value", encodeUtf8 v)] $ + r { requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : requestHeaders r + , path = "/service/" <> encodeUtf8 s <> "/dictionary/" <> encodeUtf8 d <> "/item/" <> urlEncode False (encodeUtf8 k) + } + +data DictionaryItemOp = CreateItem { dictionaryOpKey :: Text, dictionaryOpValue :: Text } + | UpdateItem { dictionaryOpKey :: Text, dictionaryOpValue :: Text } + | UpsertItem { dictionaryOpKey :: Text, dictionaryOpValue :: Text } + | DeleteItem { dictionaryOpKey :: Text } + +instance ToJSON DictionaryItemOp where + toJSON (CreateItem k v) = object [ "op" .= String "create" + , "item_key" .= k + , "item_value" .= v + ] + toJSON (UpdateItem k v) = object [ "op" .= String "update" + , "item_key" .= k + , "item_value" .= v + ] + toJSON (UpsertItem k v) = object [ "op" .= String "upsert" + , "item_key" .= k + , "item_value" .= v + ] + toJSON (DeleteItem k) = object [ "op" .= String "delete" + , "item_key" .= k + ] + +data BatchEditResult = BatchEditResult + { batchEditResultStatus :: Text + } deriving (Show, Generic) + +instance ToJSON BatchEditResult where + toJSON = genericToJSON (jsonOpts 15) + +instance FromJSON BatchEditResult where + parseJSON = genericParseJSON (jsonOpts 15) + +batchEditDictionaryItems :: FastlyClient + -> ServiceId + -> DictionaryId + -> [DictionaryItemOp] + -> FastlyM BatchEditResult +batchEditDictionaryItems c (ServiceId s) (DictionaryId d) ops = patch c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/dictionary/" <> encodeUtf8 d <> "/items" + , requestBody = RequestBodyLBS $ encode $ object [ "items" .= ops ] + } + +data DeleteDictionaryItemResult = DeleteDictionaryItemResult + { deleteDictionaryItemResultStatus :: Text + } deriving (Show, Generic) + +instance ToJSON DeleteDictionaryItemResult where + toJSON = genericToJSON (jsonOpts 26) + +instance FromJSON DeleteDictionaryItemResult where + parseJSON = genericParseJSON (jsonOpts 26) + +deleteDictionaryItem :: FastlyClient + -> ServiceId + -> DictionaryId + -> Text -- ^ Key + -> FastlyM DeleteDictionaryItemResult +deleteDictionaryItem c (ServiceId s) (DictionaryId d) k = delete c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/dictionary/" <> encodeUtf8 d <> "/item/" <> urlEncode False (encodeUtf8 k) } + +data Domain = Domain + { domainComment :: Text + , domainLocked :: Bool + , domainName :: Text + , domainServiceId :: ServiceId + , domainVersion :: ServiceVersionNumber + , domainUpdatedAt :: Maybe Timestamp + , domainDeletedAt :: Maybe Timestamp + , domainCreatedAt :: Maybe Timestamp + } deriving (Show, Generic) + +instance ToJSON Domain where + toJSON = genericToJSON (jsonOpts 6) + +instance FromJSON Domain where + parseJSON = genericParseJSON (jsonOpts 6) + +checkDomainRecords + :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> FastlyM [(Domain, Text, Bool)] +checkDomainRecords c (ServiceId s) (ServiceVersionNumber v) = get c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/version/" <> BS.pack (show v) <> "/domain/check_all" } + +checkDomainRecord + :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text + -> FastlyM (Domain, Text, Bool) +checkDomainRecord c (ServiceId s) (ServiceVersionNumber v) n = get c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/version/" <> BS.pack (show v) <> "/domain/" <> urlEncode False (encodeUtf8 n) <> "/check" } + +listDomains + :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> FastlyM [Domain] +listDomains c (ServiceId s) (ServiceVersionNumber v) = get c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/version/" <> BS.pack (show v) <> "/domain" } + +getDomain + :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text + -> FastlyM Domain +getDomain c (ServiceId s) (ServiceVersionNumber v) n = get c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/version/" <> BS.pack (show v) <> "/domain/" <> urlEncode False (encodeUtf8 n) } + +createDomain + :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text -- ^ Domain name + -> FastlyM Domain +createDomain c (ServiceId s) (ServiceVersionNumber v) n = post c $ \r -> urlEncodedBody [("name", encodeUtf8 n)] $ + r { requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : requestHeaders r + , path = "/service/" <> encodeUtf8 s <> "/version/" <> BS.pack (show v) <> "/domain" + } + + + +toJsonSpaceList :: [Text] -> Value +toJsonSpaceList = String . T.intercalate " " + +fromJsonSpaceList :: Monad m => Value -> m [Text] +fromJsonSpaceList (String ts) = return $ T.splitOn " " ts +fromJsonSpaceList wat = fail "Expected a String, got something else for JSON space-delimited list" + +newtype ContentTypes = ContentTypes [Text] + deriving (Show) + +instance ToJSON ContentTypes where + toJSON (ContentTypes ts) = toJsonSpaceList ts + +instance FromJSON ContentTypes where + parseJSON ts = ContentTypes <$> fromJsonSpaceList ts + +newtype Extensions = Extensions [Text] + deriving (Show) + +instance ToJSON Extensions where + toJSON (Extensions ts) = toJsonSpaceList ts + +instance FromJSON Extensions where + parseJSON ts = Extensions <$> fromJsonSpaceList ts + +data GzipConfiguration = GzipConfiguration + { gzipConfigurationCacheCondition :: Text + , gzipConfigurationContentTypes :: ContentTypes + , gzipConfigurationExtensions :: Extensions + , gzipConfigurationName :: Text + , gzipConfigurationServiceId :: ServiceId + , gzipConfigurationVersion :: ServiceVersionNumber + } deriving (Show, Generic) + +instance ToJSON GzipConfiguration where + toJSON = genericToJSON (jsonOpts 17) + +instance FromJSON GzipConfiguration where + parseJSON = genericParseJSON (jsonOpts 17) + +listGzipConfigurations :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> FastlyM [GzipConfiguration] +listGzipConfigurations c (ServiceId s) (ServiceVersionNumber v) = get c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/version/" <> BS.pack (show v) <> "/gzip" } + +getGzipConfiguration :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text -- ^ Configuration name + -> FastlyM GzipConfiguration +getGzipConfiguration c (ServiceId s) (ServiceVersionNumber v) n = get c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/version/" <> BS.pack (show v) <> "/gzip/" <> urlEncode False (encodeUtf8 n) } + +data DeleteGzipConfigurationResult = DeleteGzipConfigurationResult + { deleteGzipConfigurationResultStatus :: Text + } deriving (Show, Generic) + +instance ToJSON DeleteGzipConfigurationResult where + toJSON = genericToJSON (jsonOpts 29) + +instance FromJSON DeleteGzipConfigurationResult where + parseJSON = genericParseJSON (jsonOpts 29) + +deleteGzipConfiguration :: FastlyClient + -> ServiceId + -> ServiceVersionNumber + -> Text -- ^ Configuration name + -> FastlyM DeleteGzipConfigurationResult +deleteGzipConfiguration c (ServiceId s) (ServiceVersionNumber v) n = delete c $ \r -> + r { path = "/service/" <> encodeUtf8 s <> "/version/" <> BS.pack (show v) <> "/gzip/" <> urlEncode False (encodeUtf8 n) } + + +data HeaderAction = SetHeader + | AppendHeader + | DeleteHeader + | RegexHeader + | RegexRepeatHeader + +data HeaderType = Request + | Fetch + | Cache + | Response + +data Header = Header + { headerAction :: HeaderAction + , headerCacheCondition :: Maybe Text + , headerDst :: Text + , headerIgnoreIfSet :: Int -- ^ TODO it's actually a bool, except for JSON format + , headerName :: Text + , headerPriority :: Int + , headerRegex :: Text + , headerRequestCondition :: Text + , headerResponseCondition :: Text + , headerServiceId :: ServiceId + , headerSrc :: Text + , headerSubstitution :: Text + , headerType :: HeaderType + , headerVersion :: ServiceVersionNumber + } + + + + + +newtype ServiceVersionNumber = ServiceVersionNumber Int + deriving (Show, ToJSON) + +instance FromJSON ServiceVersionNumber where + parseJSON (String str) = return $ ServiceVersionNumber $ read $ unpack str + parseJSON num@(Number n) = fmap ServiceVersionNumber $ parseJSON num + parseJSON wat = typeMismatch "ServiceVersion" wat + +newtype ServiceId = ServiceId Text + deriving (Show, ToJSON, FromJSON) + +newtype CustomerId = CustomerId Text + deriving (Show, ToJSON, FromJSON) + +newtype Timestamp = Timestamp { fromTimestamp :: UTCTime } + deriving (Show) + +instance ToJSON Timestamp where + toJSON (Timestamp t) = String $ pack $ formatTime defaultTimeLocale "%Y-%M-%dT%H:%M:%S" t + +instance FromJSON Timestamp where + parseJSON (String s) = let ts = unpack s in + case parseTime defaultTimeLocale "%Y-%M-%dT%H:%M:%S" ts <|> + parseTime defaultTimeLocale "%Y-%M-%dT%H:%M:%S%z" ts <|> + parseTime defaultTimeLocale "%Y-%M-%dT%H:%M:%SZ" ts of + Nothing -> fail "Invalid time parse" + Just t -> return $ Timestamp t + parseJSON wat = typeMismatch "Timestamp" wat + +newtype Boolean = Boolean Bool + deriving (Show) + +instance ToJSON Boolean where + toJSON (Boolean b) = String $ if b then "1" else "0" + +instance FromJSON Boolean where + parseJSON (String s) = case s of + "0" -> return $ Boolean False + "1" -> return $ Boolean True + parseJSON (Bool b) = return $ Boolean b + +data ServiceBasicVersion = ServiceBasicVersion + { serviceBasicVersionDeployed :: Value + , serviceBasicVersionLocked :: Maybe Boolean + , serviceBasicVersionTesting :: Maybe Boolean + , serviceBasicVersionActive :: Value + , serviceBasicVersionUpdatedAt :: Maybe Timestamp + , serviceBasicVersionDeletedAt :: Maybe Timestamp + , serviceBasicVersionServiceId :: ServiceId + , serviceBasicVersionInheritServiceId :: Maybe ServiceId + , serviceBasicVersionCreatedAt :: Maybe Timestamp + , serviceBasicVersionNumber :: ServiceVersionNumber + , serviceBasicVersionComment :: Text + , serviceBasicVersionStaging :: Value + } deriving (Show, Generic) + +instance ToJSON ServiceBasicVersion where + toJSON = genericToJSON (jsonOpts 19) + +instance FromJSON ServiceBasicVersion where + parseJSON = genericParseJSON (jsonOpts 19) + +data ServiceVersion = ServiceVersion + { serviceVersionBackends :: [Object] + , serviceVersionGzips :: [Object] + , serviceVersionDeployed :: Value + , serviceVersionVcls :: [Value] + , serviceVersionLocked :: Maybe Boolean + , serviceVersionSettings :: Object + , serviceVersionMatches :: [Value] + , serviceVersionTesting :: Value + , serviceVersionActive :: Value + , serviceVersionHeaders :: [Object] + , serviceVersionServiceId :: ServiceId + , serviceVersionResponseObjects :: [Object] + , serviceVersionConditions :: [Object] + , serviceVersionNumber :: ServiceVersionNumber + , serviceVersionDomains :: [Object] + , serviceVersionRequestSettings :: [Object] + , serviceVersionComment :: Text + , serviceVersionDirectors :: [Object] + , serviceVersionCacheSettings :: [Object] + , serviceVersionHealthchecks :: [Object] + , serviceVersionStaging :: Value + , serviceVersionWordpress :: [Object] + } deriving (Show, Generic) + +instance ToJSON ServiceVersion where + toJSON = genericToJSON (jsonOpts 14) + +instance FromJSON ServiceVersion where + parseJSON = genericParseJSON (jsonOpts 14) + +data Service = Service + { serviceId :: ServiceId + , serviceName :: Text + , serviceCustomerId :: CustomerId + , serviceComment :: Text + , serviceActiveVersion :: Maybe ServiceVersion + , serviceVersion :: Maybe ServiceVersion + , serviceVersions :: [ServiceBasicVersion] + } deriving (Show, Generic) + +instance ToJSON Service where + toJSON = genericToJSON (jsonOpts 7) + +instance FromJSON Service where + parseJSON = genericParseJSON (jsonOpts 7) + +data ServiceListItem = ServiceListItem + { serviceListItemCustomerId :: CustomerId + , serviceListItemVersions :: [ServiceBasicVersion] + , serviceListItemVersion :: ServiceVersionNumber + , serviceListItemName :: Text + , serviceListItemId :: ServiceId + , serviceListItemComment :: Text + } deriving (Show, Generic) + +instance ToJSON ServiceListItem where + toJSON = genericToJSON (jsonOpts 15) + +instance FromJSON ServiceListItem where + parseJSON = genericParseJSON (jsonOpts 15) + +listServices :: FastlyClient + -> FastlyM [ServiceListItem] +listServices c = get c $ \r -> + r { path = "/service" } + +getService :: FastlyClient + -> ServiceId + -> FastlyM Service +getService c (ServiceId sid) = get c $ \r -> + r { path = "/service/" <> encodeUtf8 sid } + +getServiceDetails :: FastlyClient + -> ServiceId + -> FastlyM Service +getServiceDetails c (ServiceId sid) = get c $ \r -> + r { path = "/service/" <> encodeUtf8 sid <> "/details" } + +getServiceByName :: FastlyClient + -> Text + -> FastlyM (Maybe Service) +getServiceByName c name = get c $ \r -> setQueryString [("name", Just $ encodeUtf8 name)] $ + r { path = "/service/search" + } + + + +data PurgeMode = Instant + | Soft + +data PurgeResult = PurgeResult + { purgeResultStatus :: Text + , purgeResultId :: Text + } deriving (Show, Generic) + +instance ToJSON PurgeResult where + toJSON = genericToJSON (jsonOpts 11) + +instance FromJSON PurgeResult where + parseJSON = genericParseJSON (jsonOpts 11) + +purge :: FastlyClient + -> PurgeMode + -> String -- ^ URL + -> FastlyM PurgeResult +purge c mode url = ExceptT $ do + m <- getGlobalManager + case parseRequest url of + Left str -> return $ Left $ InvalidUrl $ show str + Right req -> do + let f r = case mode of + Instant -> r + Soft -> (r { requestHeaders = ("Fastly-Soft-Purge", "1") : requestHeaders r}) + r <- httpLbs ((f req) { method = "PURGE" }) m + return $ case eitherDecode $ responseBody r of + Left e -> Left $ JsonError e Nothing + Right j -> case fromJSON j of + Error s -> Left $ JsonError s (Just j) + Success r -> Right r + +newtype SurrogateKey = SurrogateKey Text + +purgeKey :: FastlyClient + -> PurgeMode + -> ServiceId + -> SurrogateKey + -> FastlyM PurgeResult +purgeKey c mode (ServiceId sid) (SurrogateKey skey) = ExceptT $ do + m <- getGlobalManager + let baseReq = fastlyClientBaseRequest c + req = baseReq { method = "POST" + , path = "/service/" <> encodeUtf8 sid <> "/purge/" <> encodeUtf8 skey + , requestHeaders = case mode of + Instant -> requestHeaders baseReq + Soft -> ("Fastly-Soft-Purge", "1") : requestHeaders baseReq + } + r <- httpLbs req m + pedanticDecode r + +data PurgeAllResult = PurgeAllResult + { purgeAllResultStatus :: Text + } deriving (Show, Generic) + +instance ToJSON PurgeAllResult where + toJSON = genericToJSON (jsonOpts 14) + +instance FromJSON PurgeAllResult where + parseJSON = genericParseJSON (jsonOpts 14) + +purgeAll :: FastlyClient + -> ServiceId + -> FastlyM PurgeAllResult +purgeAll c (ServiceId sid) = ExceptT $ do + m <- getGlobalManager + let req = (fastlyClientBaseRequest c) { method = "POST" + , path = "/service/" <> encodeUtf8 sid <> "/purge_all" + } + r <- httpLbs req m + pedanticDecode r + + + + + + + + + +data CacheStatus = CacheStatus + { cacheStatusHash :: Text + , cacheStatusResponse :: CacheStatusResponse + , cacheStatusResponseTime :: Double + , cacheStatusServer :: Text + , cacheStatusRequest :: CacheStatusRequest + } deriving (Show, Generic) + +instance ToJSON CacheStatus where + toJSON = genericToJSON (jsonOpts 11) + +instance FromJSON CacheStatus where + parseJSON = genericParseJSON (jsonOpts 11) + +data CacheStatusRequest = CacheStatusRequest + { cacheStatusRequestUrl :: Maybe Text + , cacheStatusRequestHeaders :: HashMap Text Text + , cacheStatusRequestMethod :: Maybe Text + } deriving (Show, Generic) + +instance ToJSON CacheStatusRequest where + toJSON = genericToJSON (jsonOpts 18) + +instance FromJSON CacheStatusRequest where + parseJSON = genericParseJSON (jsonOpts 18) + +data CacheStatusResponse = CacheStatusResponse + { cacheStatusResponseStatus :: Int + , cacheStatusResponseHeaders :: HashMap Text Text + } deriving (Show, Generic) + +instance ToJSON CacheStatusResponse where + toJSON = genericToJSON (jsonOpts 19) + +instance FromJSON CacheStatusResponse where + parseJSON = genericParseJSON (jsonOpts 19) + +edgeCheck :: FastlyClient -> Text -> FastlyM [CacheStatus] +edgeCheck c t = get c (p . setQueryString [("url", Just $ encodeUtf8 t)]) + where + p r = r { path = "/content/edge_check" } + +data Addresses = Addresses + { addresses :: [IPRange] + } deriving (Show) + +instance FromJSON Addresses where + parseJSON (Object o) = do + r <- o .: "addresses" + return $ Addresses $ map read r + + +publicIpList :: FastlyM Addresses +publicIpList = ExceptT $ do + m <- getGlobalManager + r <- httpLbs req m + pedanticDecode r + where + (Just req) = C.parseRequest "https://api.fastly.com/public-ip-list" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Test.Hspec + +import Data.Either +import qualified Network.Fastly as F +import qualified System.Environment as Env +import qualified Data.Text as T + +surrogateKey = F.SurrogateKey "example/1" + +testService token serviceId = do + r <- F.fastly token (\client -> F.getService client serviceId) + putStrLn $ "\ngetService: " ++ show r ++ "\n" + return r + +testPurgeKey token serviceId = do + r <- F.fastly token (\client -> F.purgeKey client F.Instant serviceId surrogateKey) + putStrLn $ "\npurgeKey: " ++ show r ++ "\n" + return r + +testPurgeAll token serviceId = do + r <- F.fastly token $ \client -> F.purgeAll client serviceId + putStrLn $ "\npurgeAll: " ++ show r ++ "\n" + return r + +purgeKeyOk (Right (F.PurgeResult {F.purgeResultStatus = "ok", F.purgeResultId = _})) = True +purgeKeyOk _ = False + +purgeAllOk (Right (F.PurgeAllResult {F.purgeAllResultStatus = "ok"})) = True +purgeAllOk _ = False + +tests token serviceId = do + getServiceResult <- testService token serviceId + purgeKeyResult <- testPurgeKey token serviceId + purgeAllResult <- testPurgeAll token serviceId + hspec $ do + describe "getService" $ do + it "is okay" $ do + getServiceResult `shouldSatisfy` isRight + describe "purgeKey" $ do + it "is okay" $ do + purgeKeyResult `shouldSatisfy` purgeKeyOk + describe "purgeAll" $ do + it "is okay" $ do + purgeAllResult `shouldSatisfy` purgeAllOk + +main :: IO () +main = do + token <- Env.getEnv "FASTLY_TOKEN" + serviceId <- Env.getEnv "FASTLY_SERVICE_ID" + tests (T.pack token) (F.ServiceId (T.pack serviceId))