dozens (empty) → 0.1.0
raw patch · 8 files changed
+656/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, data-default-class, http-client, http-client-tls, http-types, reflection, scientific, text, transformers
Files
- LICENSE +20/−0
- Network/API/Dozens.hs +68/−0
- Network/API/Dozens/API.hs +62/−0
- Network/API/Dozens/Common.hs +21/−0
- Network/API/Dozens/Explicit.hs +49/−0
- Network/API/Dozens/Internal.hs +397/−0
- Setup.hs +2/−0
- dozens.cabal +37/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 philopon++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Network/API/Dozens.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++module Network.API.Dozens+ ( Dozens, withDozens+ , API(..)++ , module Network.API.Dozens.API+ , module Network.API.Dozens.Common+ ) where+++import Control.Monad.IO.Class+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative((<$>), (<*>), pure)+#endif++import Network.HTTP.Client+import qualified Network.API.Dozens.Internal as I++import Network.API.Dozens.API+import Network.API.Dozens.Common++import Data.Reflection++data Dozens = Dozens+ { dozensToken :: I.Token+ , dozensManager :: Manager+ }++withDozens :: MonadIO m => I.Auth -> (Given Dozens => m a) -> Manager -> m a+withDozens auth m mgr = do+ doz <- liftIO $ Dozens <$> I.authorize auth mgr <*> pure mgr+ give doz m++class API a r | a -> r where+ run :: (MonadIO m, Given Dozens) => a -> m r++wrap :: (MonadIO m, Given Dozens) => (a -> I.Token -> Manager -> IO r) -> a -> m r+wrap f a = liftIO $ f a (dozensToken given) (dozensManager given)++instance API GetZone [Zone] where+ run = wrap $ const I.getZone++instance API CreateZone [Zone] where+ run = wrap I.createZone++instance API UpdateZone [Zone] where+ run = wrap I.updateZone++instance API DeleteZone [Zone] where+ run = wrap I.deleteZone++instance API GetRecords [Record] where+ run = wrap I.getRecords++instance API CreateRecord [Record] where+ run = wrap I.createRecord++instance API UpdateRecord [Record] where+ run = wrap I.updateRecord++instance API DeleteRecord [Record] where+ run = wrap I.deleteRecord
+ Network/API/Dozens/API.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.API.Dozens.API+ ( -- * Zone+ -- ** get+ GetZone, getZone++ -- ** create+ , I.CreateZone(..), createZone++ -- ** update+ , I.UpdateZone(..), updateZone++ -- ** delete+ , I.DeleteZone(..), deleteZone++ -- * Record+ -- ** get+ , I.GetRecords(..), getRecords++ -- ** create+ , I.CreateRecord(..), createRecord++ -- ** update+ , I.UpdateRecord(..), updateRecord++ -- ** delete+ , I.DeleteRecord(..), deleteRecord++ -- * aliases+ , I.User, I.Key, I.ZoneName, I.MailAddress++ ) where++import qualified Network.API.Dozens.Internal as I++data GetZone = GetZone+ deriving (Show, Read, Eq)++getZone :: GetZone+getZone = GetZone++createZone :: I.CreateZone+createZone = I.CreateZone "" Nothing Nothing++updateZone :: I.UpdateZone+updateZone = I.UpdateZone (I.ZoneId 0) ""++deleteZone :: I.DeleteZone+deleteZone = I.DeleteZone (I.ZoneId 0)++getRecords :: I.GetRecords+getRecords = I.GetRecords ""++createRecord :: I.CreateRecord+createRecord = I.CreateRecord "" "" I.A Nothing Nothing ""++updateRecord :: I.UpdateRecord+updateRecord = I.UpdateRecord (I.RecordId 0) Nothing Nothing Nothing++deleteRecord :: I.DeleteRecord+deleteRecord = I.DeleteRecord (I.RecordId 0)
+ Network/API/Dozens/Common.hs view
@@ -0,0 +1,21 @@+module Network.API.Dozens.Common+ ( Auth(..)+ , Token++ -- * zone+ , ZoneId+ , Zone(..)++ -- * record+ , RecordId+ , RecordType(..)+ , Record(..)++ -- * aliases+ , User, Key, ZoneName, MailAddress++ , def+ ) where++import Network.API.Dozens.Internal+import Data.Default.Class
+ Network/API/Dozens/Explicit.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++module Network.API.Dozens.Explicit+ ( -- * authorize+ I.authorize+ , I.fromToken++ -- * API+ , API(..)++ , module Network.API.Dozens.API+ , module Network.API.Dozens.Common+ ) where++import Network.HTTP.Client+import qualified Network.API.Dozens.Internal as I++import Network.API.Dozens.Common+import Network.API.Dozens.API++class API a r | a -> r where+ run :: a -> I.Token -> Manager -> IO r++instance API GetZone [Zone] where+ run _ = I.getZone++instance API I.CreateZone [Zone] where+ run = I.createZone++instance API I.UpdateZone [Zone] where+ run = I.updateZone++instance API DeleteZone [Zone] where+ run = I.deleteZone++instance API GetRecords [Record] where+ run = I.getRecords++instance API I.CreateRecord [Record] where+ run = I.createRecord++instance API I.UpdateRecord [Record] where+ run = I.updateRecord++instance API DeleteRecord [Record] where+ run = I.deleteRecord
+ Network/API/Dozens/Internal.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Network.API.Dozens.Internal+ ( -- * types+ User, Key, ZoneName, MailAddress+ , DozensException(..)++ -- * authorize+ , Auth(..)+ , Token+ , authorize+ , fromToken++ -- * zone+ , ZoneId(..)+ , Zone(..)++ -- ** get+ , getZone++ -- ** create+ , CreateZone(..)+ , createZone++ -- ** update+ , UpdateZone(..)+ , updateZone++ -- ** delete+ , DeleteZone(..)+ , deleteZone+ + -- * record+ , RecordType(..)+ , RecordId(..)+ , Record(..)++ -- ** get+ , GetRecords(..)+ , getRecords++ -- ** create+ , CreateRecord(..)+ , createRecord++ -- ** update+ , UpdateRecord(..)+ , updateRecord++ -- ** delete+ , DeleteRecord(..)+ , deleteRecord+ ) where++import Control.Monad(join)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative((<$>), (<*>), pure)+#endif+import Control.Exception(Exception, throwIO, catch)+import Control.Concurrent(MVar, newMVar, withMVar, modifyMVar_)++import Network.HTTP.Types.Status(statusCode)+import Network.HTTP.Client++import Text.Read(readMaybe)++import Data.Scientific+import Data.Default.Class(Default(..))+import Data.Word(Word16)+import Data.Typeable(Typeable)+import Data.Aeson(eitherDecode, encode)+import Data.Aeson.Types(FromJSON(..), ToJSON(..), parseEither, (.:), Value(..), object, (.=), Parser)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as SC++type User = S.ByteString+type Key = S.ByteString++type ZoneName = S.ByteString++data Auth = Auth+ { authUser :: User+ , authKey :: Key+ , apiBase :: Request+ } deriving Show++instance Default Auth where+ def = Auth "USER" "KEY" "https://dozens.jp"++data Token = Token+ { tokenBody :: MVar S.ByteString+ , tokenAuth :: Auth+ }++data DozensException+ = AesonParseFailed String+ deriving(Show, Typeable)++instance Exception DozensException++authorize' :: Auth -> Manager -> IO S.ByteString+authorize' auth mgr = getToken =<< httpLbs request mgr+ where+ getToken =+ either (throwIO . AesonParseFailed) (return . T.encodeUtf8)+ . join+ . fmap (parseEither (.: "auth_token"))+ . eitherDecode+ . responseBody++ request = (apiBase auth)+ { path = "/api/authorize.json"+ , requestHeaders =+ [ ("X-Auth-User", authUser auth)+ , ("X-Auth-Key", authKey auth)+ ]+ }++fromToken :: Auth -> S.ByteString -> IO Token+fromToken auth tok = Token <$> (newMVar tok) <*> pure auth++authorize :: Auth -> Manager -> IO Token+authorize auth mgr = authorize' auth mgr >>= \tok -> fromToken auth tok++rawApi' :: FromJSON a => Bool -> (Request -> Request) -> Token -> Manager -> IO a+rawApi' retry f tok mgr = handle401 retry $ withMVar (tokenBody tok) $ \tokBdy ->+ either (throwIO . AesonParseFailed) return+ . eitherDecode+ . responseBody =<< httpLbs (f . authToken tokBdy . apiBase $ tokenAuth tok) mgr++ where+ authToken tokBdy req = req+ { requestHeaders =+ ("X-Auth-Token", tokBdy) :+ ("Content-Type", "application/json") :+ requestHeaders req+ }++ handle401 False io = io+ handle401 True io = io `catch` \case+ StatusCodeException (statusCode -> 401) _ _ ->+ reAuth >> rawApi' False f tok mgr+ other -> throwIO other++ reAuth = modifyMVar_ (tokenBody tok) $ \_ ->+ authorize' (tokenAuth tok) mgr++rawApi :: FromJSON a => (Request -> Request) -> Token -> Manager -> IO a+rawApi = rawApi' True++jsonInt :: (Integral i, Read i) => Value -> Parser i+jsonInt (String s) =+ maybe (fail $ "cannot read JSON string as Int: " ++ show s) return+ . readMaybe $ T.unpack s+jsonInt (Number n) = either (fail . ("cannot read JSON floating as Int: " ++) . show :: Double -> Parser a) return (floatingOrInteger n)+jsonInt a = fail $ "cannot read JSON as Int: " ++ show a++newtype ZoneId = ZoneId Int+ deriving (Show, Eq, Read, Typeable)++newtype ZoneId' = ZoneId' { unZoneId' :: ZoneId }++instance FromJSON ZoneId' where+ parseJSON = fmap (ZoneId' . ZoneId) . jsonInt++unZoneId :: ZoneId -> Int+unZoneId (ZoneId z) = z++data Zone = Zone { zoneId :: ZoneId, zoneName :: ZoneName }+ deriving (Show, Eq, Read, Typeable)++newtype Zone' = Zone' { unZone' :: Zone }++instance FromJSON Zone' where+ parseJSON (Object o) = fmap Zone' $ Zone+ <$> (unZoneId' <$> o .: "id")+ <*> (T.encodeUtf8 <$> o .: "name")+ parseJSON _ = fail "Zone: not object"++newtype Domain = Domain { unDomain :: [Zone] }++instance FromJSON Domain where+ parseJSON (Object o) = Domain . map unZone' <$> o .: "domain"+ parseJSON _ = fail "Domain: not object"++retZone :: Functor f => (tok -> mgr -> f Domain) -> tok -> mgr -> f [Zone]+retZone f tok mgr = unDomain <$> f tok mgr++getZone :: Token -> Manager -> IO [Zone]+getZone = retZone $ rawApi $ \r -> r {path = "/api/zone.json"}++type MailAddress = S.ByteString++data CreateZone = CreateZone+ { czZoneName :: ZoneName+ , czGoogleAppsAuthorize :: Maybe S.ByteString+ , czMailAddress :: Maybe MailAddress+ } deriving (Show, Read, Eq, Typeable)++newtype CreateZone' = CreateZone' CreateZone++instance ToJSON CreateZone' where+ toJSON (CreateZone' CreateZone{..}) = object $+ maybe id (\m -> (:) ("mailaddress" .= T.decodeUtf8 m)) czMailAddress $+ maybe id (\g -> (:) ("google_authorize" .= T.decodeUtf8 g)) czGoogleAppsAuthorize $+ "name" .= T.decodeUtf8 czZoneName :+ ["add_google_apps" .= maybe False (const True) czGoogleAppsAuthorize]++rawPostApi :: (ToJSON d, FromJSON a) => d -> (Request -> Request) -> Token -> Manager -> IO a+rawPostApi d f = rawApi $ \r -> f $ r+ { method = "POST"+ , requestBody = RequestBodyLBS $ encode d+ }++createZone :: CreateZone -> Token -> Manager -> IO [Zone]+createZone cz = retZone $ rawPostApi (CreateZone' cz) $ \r ->+ r { path = "/api/zone/create.json" }++data UpdateZone = UpdateZone+ { uzZoneId :: ZoneId+ , uzMailAddress :: MailAddress+ } deriving (Show, Read, Eq, Typeable)++updateZone :: UpdateZone -> Token -> Manager -> IO [Zone]+updateZone z = retZone $ rawPostApi d $ \r -> r+ { path = S.concat+ [ "/api/zone/update/"+ , (SC.pack . show . unZoneId . uzZoneId) z+ , ".json"+ ]+ }+ where+ d = object ["mailaddress" .= T.decodeUtf8 (uzMailAddress z)]++newtype DeleteZone = DeleteZone { dzZoneId :: ZoneId }+ deriving (Show, Read, Eq)++deleteZone :: DeleteZone -> Token -> Manager -> IO [Zone]+deleteZone (DeleteZone z) = retZone $ rawApi $ \r -> r+ { method = "DELETE"+ , path = S.concat+ [ "/api/zone/delete/"+ , (SC.pack . show . unZoneId) z+ , ".json"+ ]+ }++data RecordType = A | AAAA | CNAME | MX | TXT+ deriving (Show, Eq, Read, Typeable)++newtype RecordType' = RecordType' { unRecordType' :: RecordType }++instance FromJSON RecordType' where+ parseJSON (String t) = RecordType' <$> case t of+ "A" -> return A+ "AAAA" -> return AAAA+ "CNAME" -> return CNAME+ "MX" -> return MX+ "TXT" -> return TXT+ o -> fail $ "unknown RecordType: " ++ show o+ parseJSON _ = fail "RecordType: not string"++instance ToJSON RecordType' where+ toJSON t = case unRecordType' t of+ A -> "A"+ AAAA -> "AAAA"+ CNAME -> "CNAME"+ MX -> "MX"+ TXT -> "TXT"++newtype RecordId = RecordId Int+ deriving (Show, Eq, Read, Typeable)++unRecordId :: RecordId -> Int+unRecordId (RecordId i) = i++newtype RecordId' = RecordId' { unRecordId' :: RecordId }++instance FromJSON RecordId' where+ parseJSON = fmap (RecordId' . RecordId) . jsonInt++data Record = Record+ { recordId :: RecordId+ , recordName :: S.ByteString+ , recordType :: RecordType+ , recordPriority :: Maybe Word16+ , recordTtl :: Int+ , recordBody :: S.ByteString+ } deriving (Show, Eq, Read, Typeable)++newtype Record' = Record' { unRecord' :: Record }++instance FromJSON Record' where+ parseJSON (Object o) = fmap Record' $ Record+ <$> (unRecordId' <$> o .: "id")+ <*> (T.encodeUtf8 <$> o .: "name")+ <*> (unRecordType' <$> o .: "type")+ <*> (o .: "prio" >>= parsePriority)+ <*> (o .: "ttl" >>= jsonInt)+ <*> (T.encodeUtf8 <$> o .: "content")+ where+ parsePriority Null = return Nothing+ parsePriority j = Just <$> jsonInt j+ parseJSON _ = fail "Record: not object"++newtype Records = Records { unRecords :: [Record] }++instance FromJSON Records where+ parseJSON (Object o) = Records . map unRecord' <$> o .: "record"+ parseJSON (Array _) = return $ Records []+ parseJSON o = fail $ "Records: not object: " ++ show o++retRecords :: Functor f => (tok -> mgr -> f Records) -> tok -> mgr -> f [Record]+retRecords f tok mgr = unRecords <$> f tok mgr++newtype GetRecords = GetRecords { grZoneName :: ZoneName }+ deriving (Show, Read, Eq)++getRecords :: GetRecords -> Token -> Manager -> IO [Record]+getRecords (GetRecords zn) = retRecords $ rawApi $ \r -> r+ { path = S.concat+ [ "/api/record/"+ , zn+ , ".json"+ ]+ }++data CreateRecord = CreateRecord+ { crDomain :: ZoneName+ , crName :: S.ByteString+ , crType :: RecordType+ , crPriority :: Maybe Word16+ , crTtl :: Maybe Int+ , crBody :: S.ByteString+ } deriving (Show, Eq, Read, Typeable)++newtype CreateRecord' = CreateRecord' CreateRecord++instance ToJSON CreateRecord' where+ toJSON (CreateRecord' CreateRecord{..}) = object $+ maybe id (\p -> (:) ("prio" .= p)) crPriority $+ maybe id (\t -> (:) ("ttl" .= t)) crTtl $+ [ "domain" .= T.decodeUtf8 crDomain+ , "name" .= T.decodeUtf8 crName+ , "type" .= RecordType' crType+ , "content" .= T.decodeUtf8 crBody+ ]++createRecord :: CreateRecord -> Token -> Manager -> IO [Record]+createRecord cr = retRecords $ rawPostApi (CreateRecord' cr) $ \r -> r+ { path = "/api/record/create.json" }++data UpdateRecord = UpdateRecord+ { urRecordId :: RecordId+ , urPriority :: Maybe Word16+ , urTtl :: Maybe Int+ , urBody :: Maybe S.ByteString+ } deriving (Show, Eq, Read, Typeable)++newtype UpdateRecord' = UpdateRecord' UpdateRecord++instance ToJSON UpdateRecord' where+ toJSON (UpdateRecord' UpdateRecord{..}) = object $+ maybe id (\p -> (:) ("prio" .= p)) urPriority $+ maybe id (\b -> (:) ("content" .= T.decodeUtf8 b)) urBody $+ maybe id (\t -> (:) ("ttl" .= t)) urTtl $+ []++updateRecord :: UpdateRecord -> Token -> Manager -> IO [Record]+updateRecord ur = retRecords $ rawPostApi (UpdateRecord' ur) $ \r -> r+ { path = S.concat+ [ "/api/record/update/"+ , (SC.pack . show . unRecordId . urRecordId) ur+ , ".json"+ ]+ }++newtype DeleteRecord = DeleteRecord { drRecordId :: RecordId }+ deriving (Show, Read, Eq)++deleteRecord :: DeleteRecord -> Token -> Manager -> IO [Record]+deleteRecord (DeleteRecord rid) = retRecords $ rawApi $ \r -> r+ { method = "DELETE"+ , path = S.concat+ [ "/api/record/delete/"+ , (SC.pack . show . unRecordId) rid+ , ".json"+ ]+ }
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dozens.cabal view
@@ -0,0 +1,37 @@+name: dozens+version: 0.1.0+synopsis: dozens api library+description: + dozens(<https://dozens.jp/>) api library+ .+ examples: <https://github.com/philopon/dozens-hs/blob/master/examples/>+license: MIT+license-file: LICENSE+author: HirotomoMoriwaki<philopon.dependence@gmail.com>+maintainer: HirotomoMoriwaki<philopon.dependence@gmail.com>+Homepage: https://github.com/philopon/apiary+Bug-reports: https://github.com/philopon/apiary/issues+copyright: (c) 2015 Hirotomo Moriwaki+category: Web+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Network.API.Dozens+ Network.API.Dozens.Common+ Network.API.Dozens.API+ Network.API.Dozens.Explicit+ other-modules: Network.API.Dozens.Internal+ build-depends: base >=4.6 && <4.9+ , transformers >=0.4 && <0.5+ , http-client >=0.4 && <0.5+ , http-client-tls >=0.2 && <0.3+ , http-types >=0.8 && <0.9+ , aeson >=0.9 && <0.10+ , text >=1.2 && <1.3+ , bytestring >=0.10 && <0.11+ , data-default-class >=0.0 && <0.1+ , scientific >=0.3 && <0.4+ , reflection >=1.5 && <1.6+ ghc-options: -O2 -Wall+ default-language: Haskell2010