module Web.MangoPay.Types where
import Control.Applicative
import Control.Exception.Lifted (Exception, throwIO)
import Control.Monad.Base (MonadBase)
import Data.Text as T hiding (singleton)
import Data.Text.Read as T
import Data.Typeable (Typeable)
import Data.ByteString as BS (ByteString)
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Aeson
import Data.Default
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.UTF8 as UTF8
import Data.Maybe (listToMaybe)
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import Control.Monad.Logger
import Data.Aeson.Encode (encodeToTextBuilder)
import Data.Text.Lazy.Builder (fromText, toLazyText, singleton)
import Data.Monoid ((<>), mempty)
import Data.Text.Lazy (toStrict)
import Data.String (fromString, IsString)
import qualified Data.Vector as V (length)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qLocation)
import Text.Printf (printf)
import qualified Data.ByteString.Lazy as BS (toStrict)
data AccessPoint = Sandbox | Production | Custom ByteString
deriving (Show,Read,Eq,Ord,Typeable)
getAccessPointURL :: AccessPoint -> ByteString
getAccessPointURL Sandbox="api.sandbox.mangopay.com"
getAccessPointURL Production="api.mangopay.com"
getAccessPointURL (Custom bs)=bs
data Credentials = Credentials {
cClientId :: Text
,cName :: Text
,cEmail :: Text
,cClientSecret :: Maybe Text
}
deriving (Show,Read,Eq,Ord,Typeable)
instance ToJSON Credentials where
toJSON c=object ["ClientId" .= cClientId c, "Name" .= cName c , "Email" .= cEmail c,"Passphrase" .= cClientSecret c]
instance FromJSON Credentials where
parseJSON (Object v) =Credentials <$>
v .: "ClientId" <*>
v .: "Name" <*>
v .: "Email" <*>
v .: "Passphrase"
parseJSON _= fail "Credentials"
clientIdBS :: Credentials -> ByteString
clientIdBS=TE.encodeUtf8 . cClientId
newtype AccessToken=AccessToken ByteString
deriving (Eq, Ord, Read, Show, Typeable)
data OAuthToken = OAuthToken {
oaAccessToken :: Text
,oaTokenType :: Text
,oaExpires :: Int
}
deriving (Show,Read,Eq,Ord,Typeable)
instance ToJSON OAuthToken where
toJSON oa=object ["access_token" .= oaAccessToken oa, "token_type" .= oaTokenType oa, "expires_in" .= oaExpires oa]
instance FromJSON OAuthToken where
parseJSON (Object v) =OAuthToken <$>
v .: "access_token" <*>
v .: "token_type" <*>
v .: "expires_in"
parseJSON _= fail "OAuthToken"
toAccessToken :: OAuthToken -> AccessToken
toAccessToken oa=AccessToken $ TE.encodeUtf8 $ T.concat [oaTokenType oa, " ",oaAccessToken oa]
data MpException = MpJSONException String
| MpAppException MpError
| MpHttpException H.HttpException (Maybe Value)
| MpHttpExceptionS String (Maybe Value)
deriving (Show,Typeable)
instance Exception MpException
instance ToJSON MpException where
toJSON (MpJSONException j) = object ["Type" .= ("MpJSONException"::Text), "Error" .= j]
toJSON (MpAppException mpe) = object ["Type" .= ("MpAppException"::Text), "Error" .= toJSON mpe]
toJSON (MpHttpException e v) = object ["Type" .= ("MpHttpException"::Text), "Error" .= (show e), "Value" .= v]
toJSON (MpHttpExceptionS e v) = object ["Type" .= ("MpHttpException"::Text), "Error" .= e, "Value" .= v]
instance FromJSON MpException where
parseJSON (Object v) = do
typ::String <- v .: "Type"
case typ of
"MpJSONException" -> MpJSONException <$> v .: "Error"
"MpAppException" -> MpAppException <$> v .: "Error"
"MpHttpException" -> MpHttpExceptionS <$> v .: "Error" <*> v .:? "Value"
_ -> fail $ "MpException:" ++ typ
parseJSON _= fail "MpException"
data MpError = MpError {
igeId :: Text
,igeType :: Text
,igeMessage :: Text
,igeDate :: Maybe POSIXTime
}
deriving (Show,Eq,Ord,Typeable)
instance ToJSON MpError where
toJSON mpe=object ["Id" .= igeId mpe, "Type" .= igeType mpe, "Message" .= igeMessage mpe, "Date" .= igeDate mpe]
instance FromJSON MpError where
parseJSON (Object v) = MpError <$>
v .: "Id" <*>
v .: "Type" <*>
v .: "Message" <*>
v .: "Date"
parseJSON _= fail "MpError"
instance FromJSON POSIXTime where
parseJSON n@(Number _)=(fromIntegral . (round::Double -> Integer)) <$> parseJSON n
parseJSON _ = fail "POSIXTime"
instance ToJSON POSIXTime where
toJSON pt=toJSON (round pt :: Integer)
data Pagination = Pagination {
pPage :: Integer
,pPerPage :: Integer
}
deriving (Show,Read,Eq,Ord,Typeable)
instance Default Pagination where
def=Pagination 1 10
paginationAttributes :: Maybe Pagination -> [(ByteString,Maybe ByteString)]
paginationAttributes (Just p)=["page" ?+ pPage p, "per_page" ?+ pPerPage p]
paginationAttributes _=[]
data PagedList a= PagedList {
plData :: [a]
,plItemCount :: Integer
,plPageCount :: Integer
}
deriving (Show,Read,Eq,Ord,Typeable)
type CardId=Text
type Currency=Text
data CardExpiration = CardExpiration {
ceMonth :: Int
,ceYear :: Int
}
deriving (Show,Read,Eq,Ord,Typeable)
data Amount=Amount {
aCurrency :: Currency
,aAmount :: Integer
}
deriving (Show,Read,Eq,Ord,Typeable)
instance ToJSON Amount where
toJSON b=object ["Currency" .= aCurrency b,"Amount" .= aAmount b]
instance FromJSON Amount where
parseJSON (Object v) =Amount <$>
v .: "Currency" <*>
v .: "Amount"
parseJSON _=fail "Amount"
data IncomeRange=IncomeRange1 | IncomeRange2 | IncomeRange3 | IncomeRange4 | IncomeRange5 | IncomeRange6
deriving (Show,Read,Eq,Ord,Bounded, Enum, Typeable)
instance ToJSON IncomeRange where
toJSON IncomeRange1="1"
toJSON IncomeRange2="2"
toJSON IncomeRange3="3"
toJSON IncomeRange4="4"
toJSON IncomeRange5="5"
toJSON IncomeRange6="6"
instance FromJSON IncomeRange where
parseJSON (String "1") =pure IncomeRange1
parseJSON (String "2") =pure IncomeRange2
parseJSON (String "3") =pure IncomeRange3
parseJSON (String "4") =pure IncomeRange4
parseJSON (String "5") =pure IncomeRange5
parseJSON (String "6") =pure IncomeRange6
parseJSON (Number 1) =pure IncomeRange1
parseJSON (Number 2) =pure IncomeRange2
parseJSON (Number 3) =pure IncomeRange3
parseJSON (Number 4) =pure IncomeRange4
parseJSON (Number 5) =pure IncomeRange5
parseJSON (Number 6) =pure IncomeRange6
parseJSON _= fail "IncomeRange"
incomeBounds :: IncomeRange -> (Amount,Amount)
incomeBounds IncomeRange1 = (kEuros 0,kEuros 18)
incomeBounds IncomeRange2 = (kEuros 18,kEuros 30)
incomeBounds IncomeRange3 = (kEuros 30,kEuros 50)
incomeBounds IncomeRange4 = (kEuros 50,kEuros 80)
incomeBounds IncomeRange5 = (kEuros 80,kEuros 120)
incomeBounds IncomeRange6 = (kEuros 120,kEuros (1))
incomeRange :: Amount -> IncomeRange
incomeRange (Amount "EUR" cents)
| cents < kCents 18 = IncomeRange1
| cents < kCents 30 = IncomeRange2
| cents < kCents 50 = IncomeRange3
| cents < kCents 80 = IncomeRange4
| cents < kCents 120 = IncomeRange5
| otherwise = IncomeRange6
incomeRange (Amount _ _) = error "Amount should be given in euros"
kEuros :: Integer -> Amount
kEuros = Amount "EUR" . kCents
kCents :: Integer -> Integer
kCents ke = ke * 1000 * 100
readCardExpiration :: T.Reader CardExpiration
readCardExpiration t |
4 == T.length t,
(m,y)<-T.splitAt 2 t=do
im<-T.decimal m
iy<-T.decimal y
return (CardExpiration (fst im) (fst iy), "")
readCardExpiration _ =Left "Incorrect length"
writeCardExpiration :: CardExpiration -> Text
writeCardExpiration (CardExpiration m y)=let
sm=printf "%02d" $ checkRng m
sy=printf "%02d" $ checkRng y
in T.concat [pack sm, pack sy]
where
checkRng :: Int -> Int
checkRng i=if i > 99 then i `mod` 100 else i
instance FromJSON CardExpiration where
parseJSON (String s) |
Right (ce,"")<- readCardExpiration s=pure ce
parseJSON _=fail "CardExpiration"
instance ToJSON CardExpiration where
toJSON = toJSON . writeCardExpiration
instance IsString CardExpiration where
fromString s
| Right (ce,"")<-readCardExpiration $ fromString s=ce
fromString _=error "CardExpiration"
data KindOfAuthentication =
Light
| Regular
| Strong
deriving (Eq, Ord, Show, Read, Bounded, Enum, Typeable)
instance ToJSON KindOfAuthentication where
toJSON =toJSON . show
instance FromJSON KindOfAuthentication where
parseJSON (String s)=pure $ read $ unpack s
parseJSON _ =fail "KindOfAuthentication"
data CallRecord a = CallRecord {
crReq :: H.Request
,crResult :: Either MpException (Value,a)
}
recordLogLevel :: CallRecord a-> LogLevel
recordLogLevel cr
| HT.methodGet == H.method (crReq cr)=LevelDebug
| otherwise = LevelInfo
recordLogMessage :: CallRecord a-> Text
recordLogMessage (CallRecord req res)=let
methB=fromString $ show $ H.method req
pathB=fromText $ TE.decodeUtf8 $ H.path req
qsB=fromText $ TE.decodeUtf8 $ H.queryString req
postB=if H.method req==HT.methodPost
then case H.requestBody req of
(H.RequestBodyBS b)->fromText (TE.decodeUtf8 b) <> " -> "
(H.RequestBodyLBS b)->fromText $ TE.decodeUtf8 $ BS.toStrict b <> " -> "
_->mempty
else mempty
resB=case res of
Left e->fromString $ show e
Right (v,_)->case v of
Array arr->fromString (show $ V.length arr) <> " values"
_->encodeToTextBuilder v
in toStrict . toLazyText $ methB <> singleton ' ' <> pathB <> qsB <> ": " <> postB <> resB
recordResult :: MonadBase IO m => CallRecord a -> m a
recordResult (CallRecord _ (Left err))=throwIO err
recordResult (CallRecord _ (Right (_,a)))=return a
logCall :: Q Exp
logCall = [|\a -> monadLoggerLog $(qLocation >>= liftLoc) "mangopay" (recordLogLevel a) (recordLogMessage a)|]
class ToHtQuery a where
(?+) :: ByteString -> a -> (ByteString,Maybe ByteString)
instance ToHtQuery Double where
n ?+ d=n ?+ show d
instance ToHtQuery (Maybe Double) where
n ?+ d=n ?+ fmap show d
instance ToHtQuery Integer where
n ?+ d=n ?+ show d
instance ToHtQuery (Maybe Integer) where
n ?+ d=n ?+ fmap show d
instance ToHtQuery (Maybe POSIXTime) where
n ?+ d=n ?+ fmap (show . (round :: POSIXTime -> Integer)) d
instance ToHtQuery (Maybe T.Text) where
n ?+ d=(n,fmap TE.encodeUtf8 d)
instance ToHtQuery T.Text where
n ?+ d=(n,Just $ TE.encodeUtf8 d)
instance ToHtQuery (Maybe String) where
n ?+ d=(n,fmap UTF8.fromString d)
instance ToHtQuery String where
n ?+ d=(n,Just $ UTF8.fromString d)
findAssoc :: Eq a=> [(a,b)] -> a -> Maybe b
findAssoc xs n=listToMaybe $ Prelude.map snd $ Prelude.filter ((n==) . fst) xs
maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads