module Network.API.Dozens.Internal
(
User, Key, ZoneName, MailAddress
, DozensException(..)
, Auth(..)
, Token
, authorize
, fromToken
, ZoneId(..)
, Zone(..)
, getZone
, CreateZone(..)
, createZone
, UpdateZone(..)
, updateZone
, DeleteZone(..)
, deleteZone
, RecordType(..)
, RecordId(..)
, Record(..)
, GetRecords(..)
, getRecords
, CreateRecord(..)
, createRecord
, UpdateRecord(..)
, updateRecord
, 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"
]
}