-- Copyright (c) 2014 Sebastian Wiesner <lunaryorn@gmail.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
         -- * Package uploads
       , verifyPackage,uploadPackage,Upload(..)
       )
       where

import qualified System.IO.Magic as Magic

import qualified Data.Aeson as JSON
import qualified Data.ByteString.UTF8 as UTF8
import qualified Network as N
import qualified Network.HTTP.Client as C

import Control.Applicative ((<$>))
import Control.Exception (Exception,throwIO)
import Control.Failure (Failure(..))
import Control.Monad (liftM,mzero,unless)
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,HttpException,Request,Response)
import Network.HTTP.Client.MultipartFormData
import Network.HTTP.Types.Header (hUserAgent)
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 (Monad,MonadIO,Functor
           ,MonadState MarmaladeState)

instance Failure HttpException Marmalade where
  failure = throwMarmalade

-- |@'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 :: String          -- ^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 C.defaultManagerSettings 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 :: String -- ^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 :: String
                      , marmaladeManager :: Manager }

-- |Errors thrown by Marmalade.
data MarmaladeError = MarmaladeInvalidResponseStatus Status (Maybe String)
                      -- ^An invalid response from Marmalade, with a status and
                      -- probably an error message from Marmalade.
                    | MarmaladeInvalidResponseBody ByteString
                      -- ^Invalid response body
                    | MarmaladeBadRequest (Maybe String)
                      -- ^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 String
                      -- ^An invalid package file, with a corresponding error
                      -- message.
                      deriving Typeable

instance Show MarmaladeError where
  show (MarmaladeInvalidResponseStatus status (Just message)) =
    printf "Marmalade error: Invalid response status: %s (%s)" msgString message
    where msgString = UTF8.toString (statusMessage status)
  show (MarmaladeInvalidResponseStatus status Nothing) =
    printf "Marmalade error: Invalid response status: %s" msgString
    where msgString = UTF8.toString (statusMessage status)
  show (MarmaladeInvalidResponseBody s) =
    "Marmalade error: Invalid response body: " ++ show s
  show (MarmaladeBadRequest (Just message)) =
    "Marmalade error: Bad Request: " ++ message
  show (MarmaladeBadRequest Nothing) = "Marmalade error: Bad Request"
  show (MarmaladeInvalidPackage f m) =
    printf "Marmalade error: %s: invalid package: %s" f m

instance Exception MarmaladeError

throwMarmalade :: Exception e => e -> Marmalade a
throwMarmalade = liftIO.throwIO

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

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

-- |Authentication information for Marmalade.
data Auth = BasicAuth Username (Marmalade String)
            -- ^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
          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

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

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

-- |The base URL of Marmalade.
marmaladeURL :: String
marmaladeURL = "http://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, UTF8.fromString userAgent)]
                 -- 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 -> throwMarmalade (MarmaladeInvalidResponseBody body)
    400 -> throwMarmalade (MarmaladeBadRequest message)
    _ -> throwMarmalade (MarmaladeInvalidResponseStatus status message)
  where body = C.responseBody response
        status = C.responseStatus response
        message = fmap messageContents (JSON.decode body)

-- |Permitted package mimetypes.
packageMimeTypes :: [String]
packageMimeTypes = ["application/x-tar", "text/x-lisp"]

-- |@'verifyPackage' package@ checks whether @package@ is a valid package
-- object.
--
-- Throw an error if @package@ does not exist, or is not a valid package.
verifyPackage :: String -> Marmalade ()
verifyPackage packageFile = do
  -- Force early failure if the package doesn't exist
  mimeType <- liftIO (Magic.guessMimeType packageFile)
  unless (mimeType `elem` packageMimeTypes)
    (throwMarmalade (MarmaladeInvalidPackage packageFile
                     (printf "invalid mimetype %s" mimeType)))

-- |@'uploadPackage' package@ uploads a @package@ file to Marmalade.
--
-- Return the result of the upload, or throw an error if @package@ is not a
-- valid package, or if Marmalade refused to accept the upload.
uploadPackage :: FilePath -> Marmalade Upload
uploadPackage packageFile = do
  verifyPackage packageFile
  (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