module Web.Marmalade
(
Marmalade, runMarmalade,runMarmaladeWithManager
, MarmaladeError(..)
, Username(..), Token(..), Auth(..), login
, Message(..)
, Upload(..), uploadPackage
)
where
import Control.Applicative (Applicative,(<$>))
import Control.Exception (Exception)
import Control.Monad (liftM,mzero)
import Control.Monad.Catch (MonadThrow,MonadCatch,throwM)
import Control.Monad.IO.Class (MonadIO,liftIO)
import Control.Monad.State (StateT,MonadState,evalStateT,get,gets,put)
import Data.Aeson (FromJSON,Value(Object),(.:))
import qualified Data.Aeson as JSON
import Data.ByteString.Lazy (ByteString)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Encoding as L
import Data.Typeable (Typeable)
import qualified Network as N
import Network.HTTP.Client (Manager,Request,Response)
import qualified Network.HTTP.Client as C
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Client.MultipartFormData
import Network.HTTP.Types.Header (hUserAgent,hAccept)
import Network.HTTP.Types.Status (Status(statusCode,statusMessage))
import Text.Printf (printf)
newtype Marmalade a =
Marmalade { runM :: StateT MarmaladeState IO a }
deriving (Applicative,Functor,Monad
,MonadIO
,MonadThrow,MonadCatch
,MonadState MarmaladeState)
runMarmalade :: Text
-> Auth
-> Marmalade a
-> IO a
runMarmalade userAgent auth action =
N.withSocketsDo $ C.withManager tlsManagerSettings doIt
where doIt manager = runMarmaladeWithManager userAgent auth manager action
runMarmaladeWithManager :: Text
-> Auth
-> Manager
-> Marmalade a
-> IO a
runMarmaladeWithManager userAgent auth manager action =
evalStateT (runM action) state
where state = MarmaladeState { marmaladeAuth = auth
, marmaladeUserAgent = userAgent
, marmaladeManager = manager}
data MarmaladeState = MarmaladeState
{ marmaladeAuth :: Auth
, marmaladeUserAgent :: Text
, marmaladeManager :: Manager }
data MarmaladeError = MarmaladeInvalidResponseStatus Status L.Text
| MarmaladeInvalidResponseBody ByteString
| MarmaladeBadRequest L.Text
| MarmaladeInvalidPackage FilePath L.Text
deriving Typeable
instance Show MarmaladeError where
show (MarmaladeInvalidResponseStatus status message) =
printf "Marmalade error: Invalid response status: %s (%s)"
msgString (L.unpack message)
where msgString = T.unpack (T.decodeUtf8 (statusMessage status))
show (MarmaladeInvalidResponseBody s) =
"Marmalade error: Invalid response body: " ++ show s
show (MarmaladeBadRequest message) =
"Marmalade error: Bad Request: " ++ L.unpack message
show (MarmaladeInvalidPackage f m) =
printf "Marmalade error: %s: invalid package: %s" f (L.unpack m)
instance Exception MarmaladeError
newtype Username = Username Text deriving (Show, Eq)
newtype Token = Token Text deriving (Show, Eq)
instance FromJSON Token where
parseJSON (Object o) = Token <$> (o .: "token")
parseJSON _ = mzero
data Auth = BasicAuth Username (Marmalade Text)
| TokenAuth Username Token
login :: Marmalade (Username, Token)
login = do
state <- get
case marmaladeAuth state of
BasicAuth username getPassword -> do
token <- doLogin username getPassword
put state { marmaladeAuth = TokenAuth username token }
return (username, token)
TokenAuth username token -> return (username, token)
where doLogin (Username username) getPassword = do
manager <- gets marmaladeManager
password <- getPassword
let body = C.urlEncodedBody [ ("name", T.encodeUtf8 username)
, ("password", T.encodeUtf8 password) ]
request <- liftM body (makeRequest "/v1/users/login")
response <- liftIO (C.httpLbs request manager)
parseResponse response
newtype Message = Message { messageContents :: L.Text }
instance FromJSON Message where
parseJSON (Object o) = Message <$> (o .: "message")
parseJSON _ = mzero
newtype Upload = Upload
{ uploadMessage :: L.Text
}
instance FromJSON Upload where
parseJSON (Object o) = Upload <$> (o .: "message")
parseJSON _ = mzero
marmaladeURL :: String
marmaladeURL = "https://marmalade-repo.org"
makeRequest :: String -> Marmalade Request
makeRequest endpoint = do
initReq <- C.parseUrl (marmaladeURL ++ endpoint)
userAgent <- gets marmaladeUserAgent
return initReq { C.requestHeaders = [(hUserAgent, T.encodeUtf8 userAgent)
,(hAccept, "application/json")]
, C.checkStatus = \_ _ _ -> Nothing
}
parseResponse :: FromJSON c => Response ByteString -> Marmalade c
parseResponse response =
case statusCode status of
200 -> case JSON.decode' body of
Just o -> return o
Nothing -> throwM (MarmaladeInvalidResponseBody body)
400 -> throwM (MarmaladeBadRequest message)
_ -> throwM (MarmaladeInvalidResponseStatus status message)
where body = C.responseBody response
status = C.responseStatus response
message = maybe (L.decodeUtf8 body)
messageContents (JSON.decode' body)
uploadPackage :: FilePath -> Marmalade Upload
uploadPackage packageFile = do
(Username username, Token token) <- login
manager <- gets marmaladeManager
request <- makeRequest "/v1/packages" >>=
formDataBody [ partBS "name" (T.encodeUtf8 username)
, partBS "token" (T.encodeUtf8 token)
, partFileSource "package" packageFile]
response <- liftIO (C.httpLbs request manager)
parseResponse response