-- Copyright (c) 2014 Sebastian Wiesner <swiesner@lunaryorn.com>

-- 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.

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |Access to the API of Marmalade
module Web.Marmalade
       (
         -- * The Marmalade Monad
         Marmalade, runMarmalade,runMarmaladeWithManager
         -- * Error handling
       , MarmaladeError(..)
         -- * Authentication
       , Username(..), Token(..), Auth(..), login
         -- * Generic types
       , Message(..)
         -- * Package uploads
       , 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)

-- |The Marmalade monad.
--
-- This monad provides access to the Marmalade API.
newtype Marmalade a =
  Marmalade { runM :: StateT MarmaladeState IO a }
  deriving (Applicative,Functor,Monad
           ,MonadIO
           ,MonadThrow,MonadCatch
           ,MonadState MarmaladeState)

-- |@'runMarmalade' userAgent auth actions@ runs @actions@.
--
-- @userAgent@ is sent as @User-Agent@ header to Marmalade, and @auth@ is the
-- authentication information.
--
-- Marmalade requires a token to access most of its API, however clients can
-- "login" with a username and a password to obtain their token.
runMarmalade :: Text            -- ^The user agent sent to Marmalade
             -> Auth            -- ^The authentication information
             -> Marmalade a     -- ^The actions to run
             -> IO a
             -- ^The result of the actions, or any error thrown in the course of
             -- running the actions.
runMarmalade userAgent auth action =
  N.withSocketsDo $ C.withManager tlsManagerSettings doIt
  where doIt manager = runMarmaladeWithManager userAgent auth manager action

-- |@'runMarmaladeWithManager userAgent auth manager actions'@ runs @actions@
-- with the given connection @manager@.
--
-- Like @'runMarmalade'@, except that it lets you use your own connection
-- manager.
runMarmaladeWithManager :: Text   -- ^The user agent sent to Marmalade
                        -> Auth   -- ^The authentication information
                        -> Manager     -- ^The connection manager
                        -> Marmalade a -- ^The actions to run
                        -> IO a
                        -- ^The result of the actions, or any error thrown in
                        -- the course of running the actions.
runMarmaladeWithManager userAgent auth manager action =
  evalStateT (runM action) state
  where state = MarmaladeState { marmaladeAuth = auth
                               , marmaladeUserAgent = userAgent
                               , marmaladeManager = manager}

-- |The internal state of the @'Marmalade'@ monad.
data MarmaladeState = MarmaladeState
                      { marmaladeAuth :: Auth
                      , marmaladeUserAgent :: Text
                      , marmaladeManager :: Manager }

-- |Errors thrown by Marmalade.
data MarmaladeError = MarmaladeInvalidResponseStatus Status L.Text
                      -- ^An invalid response from Marmalade, with a status and
                      -- probably an error message from Marmalade.
                    | MarmaladeInvalidResponseBody ByteString
                      -- ^Invalid response body
                    | MarmaladeBadRequest L.Text
                      -- ^A bad request error from Marmalade.
                      --
                      -- Marmalade raises this error for failed logins and for
                      -- uploads of invalid packages (e.g. files without a
                      -- version header)
                    | MarmaladeInvalidPackage FilePath L.Text
                      -- ^An invalid package file, with a corresponding error
                      -- message.
                      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

-- |The name of a user
newtype Username = Username Text deriving (Show, Eq)
-- |An authentication token.
newtype Token = Token Text deriving (Show, Eq)

instance FromJSON Token where
  parseJSON (Object o) = Token <$> (o .: "token")
  parseJSON _          = mzero

-- |Authentication information for Marmalade.
data Auth = BasicAuth Username (Marmalade Text)
            -- ^Authentication with a username and an action that returns a
            -- password to use
          | TokenAuth Username Token
            -- ^Authentication with a username and a login token

-- |@'login'@ logs in to Marmalade to obtain the client's access token.
--
-- If the monad already uses token authentication this function is a no-op and
-- merely returns the stored token.  Otherwise it sends a login request to
-- Marmalade to obtain the token and stores the token in the monad.
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

-- |The result of an upload.
newtype Upload = Upload
                 { uploadMessage :: L.Text -- ^The message from Marmalade
                 }

instance FromJSON Upload where
  parseJSON (Object o) = Upload <$> (o .: "message")
  parseJSON _          = mzero

-- |The base URL of Marmalade.
marmaladeURL :: String
marmaladeURL = "https://marmalade-repo.org"

-- |@'makeRequest' endpoint@ creates a request to @endpoint@.
--
-- Responses to requests created by this function do not throw 'HTTPException'
-- for non-200 responses.  Use @'parseResponse'@ to turn such response into
-- @'MarmaladeError'@s.
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")]
                 -- We keep every bad status, because we handle these later
                 , C.checkStatus = \_ _ _ -> Nothing
                 }

-- |@'parseResponse' response@ parses the JSON body of @response@, or throws an
-- error for unexpected responses or invalid JSON bodies.
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' package@ uploads a @package@ file to Marmalade.
--
-- Return the result of the upload, or throw an error if Marmalade refused to
-- accept the upload.
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