module Web.Marmalade
(
Marmalade, runMarmalade,runMarmaladeWithManager
, MarmaladeError(..)
, Username(..), Token(..), Auth(..), login
, Message(..)
, Upload(..), uploadPackage
)
where
import qualified Data.Aeson as JSON
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as UTF8L
import qualified Network as N
import qualified Network.HTTP.Client as C
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 Data.ByteString.Lazy (ByteString)
import Data.Typeable (Typeable)
import Network.HTTP.Client (Manager,Request,Response)
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 :: String
-> Auth
-> Marmalade a
-> IO a
runMarmalade userAgent auth action =
N.withSocketsDo $ C.withManager C.defaultManagerSettings doIt
where doIt manager = runMarmaladeWithManager userAgent auth manager action
runMarmaladeWithManager :: String
-> 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 :: String
, marmaladeManager :: Manager }
data MarmaladeError = MarmaladeInvalidResponseStatus Status String
| MarmaladeInvalidResponseBody ByteString
| MarmaladeBadRequest String
| MarmaladeInvalidPackage FilePath String
deriving Typeable
instance Show MarmaladeError where
show (MarmaladeInvalidResponseStatus status message) =
printf "Marmalade error: Invalid response status: %s (%s)" msgString message
where msgString = UTF8.toString (statusMessage status)
show (MarmaladeInvalidResponseBody s) =
"Marmalade error: Invalid response body: " ++ show s
show (MarmaladeBadRequest message) =
"Marmalade error: Bad Request: " ++ message
show (MarmaladeInvalidPackage f m) =
printf "Marmalade error: %s: invalid package: %s" f m
instance Exception MarmaladeError
newtype Username = Username String deriving (Show, Eq)
newtype Token = Token String deriving (Show, Eq)
instance FromJSON Token where
parseJSON (Object o) = Token <$> (o .: "token")
parseJSON _ = mzero
data Auth = BasicAuth Username (Marmalade String)
| 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
request <- liftM (C.urlEncodedBody [("name", UTF8.fromString username)
,("password", UTF8.fromString password)])
(makeRequest "/v1/users/login")
response <- liftIO $ C.httpLbs request manager
parseResponse response
newtype Message = Message { messageContents :: String }
instance FromJSON Message where
parseJSON (Object o) = Message <$> (o .: "message")
parseJSON _ = mzero
newtype Upload = Upload
{ uploadMessage :: String
}
instance FromJSON Upload where
parseJSON (Object o) = Upload <$> (o .: "message")
parseJSON _ = mzero
marmaladeURL :: String
marmaladeURL = "http://marmalade-repo.org"
makeRequest :: String -> Marmalade Request
makeRequest endpoint = do
initReq <- C.parseUrl (marmaladeURL ++ endpoint)
userAgent <- gets marmaladeUserAgent
return initReq { C.requestHeaders = [(hUserAgent, UTF8.fromString 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 (UTF8L.toString 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" (UTF8.fromString username)
,partBS "token" (UTF8.fromString token)
,partFileSource "package" packageFile]
response <- liftIO (C.httpLbs request manager)
parseResponse response