fastly (empty) → 0.1.0.0
raw patch · 5 files changed
+1111/−0 lines, 5 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, bytestring-lexing, fastly, hspec, http-client, http-client-tls, http-types, iproute, mtl, old-locale, text, thyme, unordered-containers, wai
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- fastly.cabal +48/−0
- src/Network/Fastly.hs +979/−0
- test/Spec.hs +52/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fastly.cabal view
@@ -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
+ src/Network/Fastly.hs view
@@ -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"
+ test/Spec.hs view
@@ -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))