-- | This module provides the core functionality
--   that connects to the specified API and performs
--   generic GET, POST, PUT, and DELETE requests.
--   
--   Powered by the Network.HTTP.Conduit (http-conduit) package.

module PokitDok.OAuth2
    ( OAuth2(..)
    , AccessToken(..)
    , ResponseData(..)
    , Parameters
    , keyModAccessToken
    , authenticateClientCredentials
    , authenticateAuthorizationCode
    , authenticateRefreshToken
    , getRequest
    , deleteRequest
    , postRequest
    , multipartRequest
    , putRequest
    , makeUserAgentHeader
    , makeContentHeader
    , makeAuthHeader
    , appendParams
    ) where

import qualified Data.Text                  as T
import qualified Data.ByteString.Char8      as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Codec.Binary.Base64.String as B64

import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import Data.CaseInsensitive (foldCase, mk)
import Data.Time.Calendar (fromGregorian)
import Network.HTTP.Conduit
    ( Response
    , Request(method, requestHeaders, requestBody)
    , RequestBody(RequestBodyBS)
    , parseUrl
    , urlEncodedBody
    , httpLbs
    , withManager
    , responseBody
    , responseStatus
    , responseHeaders
    )
import Network.HTTP.Client.MultipartFormData
    ( Part
    , partBS
    , partFile
    , formDataBodyWithBoundary
    )
import Network.HTTP.Types (statusCode)
import Network.HTTP.Types.Header (Header)
import Network.HTTP.Base (urlEncode)
import Data.Aeson
import Data.Maybe (fromJust)

-- * Data Types

type Parameters   = [(String, String)]
type Headers      = [(String, String)]

-- | Stores OAuth2 data.
data OAuth2 = OAuth2
    { oauthClientId            :: String
    , oauthClientSecret        :: String
    , oauthAccessTokenEndpoint :: String
    , oauthOAuthorizeEndpoint  :: Maybe String
    , oauthCallback            :: Maybe String
    , oauthAccessToken         :: Maybe AccessToken
    } deriving (Show, Eq)
    

-- | OAuth access token.
data AccessToken = AccessToken
    { accessToken  :: String
    , refreshToken :: Maybe String
    , expires      :: Maybe Int -- ^ measured in POSIX seconds.
    , expiresIn    :: Maybe Int
    , token_type   :: Maybe String
    } deriving (Show, Eq)

-- | Stores http response headers, body and status code.
data ResponseData = ResponseData
    { headers :: Headers
    , body   :: String
    , status :: Int
    } deriving Show

instance FromJSON AccessToken where
    parseJSON (Object o) = AccessToken <$> at <*> rt <*> ex <*> ei <*> tt
        where
        at = o .:  T.pack "access_token"
        rt = o .:? T.pack "refresh_token"
        ex = o .:? T.pack "expires"
        ei = o .:? T.pack "expires_in"
        tt = o .:  T.pack "token_type"
    parseJSON _ = mzero

-- * Credentials

-- | Modifies the given key's @AccessToken@ with the given @'Maybe'@ @AccessToken@'s value.
keyModAccessToken :: OAuth2 -> Maybe AccessToken -> OAuth2
keyModAccessToken oauth n@Nothing = oauth { oauthAccessToken = n }
keyModAccessToken oauth j         = oauth { oauthAccessToken = j }

-- | Takes a request and returns an access token or errors.
authenticateRequest :: Request -> IO AccessToken
authenticateRequest request = do
    response <- getResponse request
    let  maybeToken = decode $ responseBody response
    case maybeToken of
        Nothing    -> error $ "***** Error decoding response:\n"++show response
        Just token -> return token

-- | Returns a valid @AccessCode@ given some headers and an @OAuth2@.
authenticateClientCredentials :: Headers -> OAuth2 -> IO AccessToken
authenticateClientCredentials headers auth@(OAuth2 _ _ url _ _ _) = do
    req <- makeRegularPostRequest url $ makeHeaders headers
    authenticateRequest $ urlEncodedBody clientCredentialParams req
    where
    clientCredentialParams = map strToBS $
        [ ("grant_type"   , "client_credentials")
        , ("client_id"    , oauthClientId auth)
        , ("client_secret", oauthClientSecret auth)
        ]

-- | Returns an @AccessToken@ given some headers, an @OAuth2@, and an authorization code.
authenticateAuthorizationCode :: Headers -> OAuth2 -> String -> IO AccessToken
authenticateAuthorizationCode headers auth@(OAuth2 _ _ url _ _ _) code = do
    req <- makeRegularPostRequest url $ makeHeaders headers
    authenticateRequest $ urlEncodedBody authorizationCodeParams req
    where
    authorizationCodeParams = map strToBS $
        [ ("grant_type"   , "authorization_code")
        , ("client_id"    , oauthClientId auth)
        , ("client_secret", oauthClientSecret auth)
        , ("redirect_uri" , fromJust $ oauthCallback auth)
        , ("code"         , code)
        , ("scope"        , "user_schedule")
        ]

-- | Takes @OAuth2@ data and returns a refreshed @AccessToken@.
authenticateRefreshToken :: Headers -> OAuth2 -> IO AccessToken
authenticateRefreshToken h a@(OAuth2 id sec url _ _ (Just (AccessToken _ (Just rt) _ _ _))) = do
    let parameters = map strToBS refreshTokenParams
    req <- makeRegularPostRequest url $ makeHeaders h
    authenticateRequest req
    where
    refreshTokenParams =
        [ ("grant_type"   , "refresh_token")
        , ("client_id"    , id)
        , ("client_secret", sec)
        , ("refresh_token", rt)
        , ("scope"        , "user_schedle")
        ]

-- * Network Calls

-- | Perform a GET request given request headers, a url, and query parameters.
getRequest :: Headers -> String -> Parameters -> IO ResponseData
getRequest headers url params = do
    req <- makeGetRequest (appendParams url params) $ makeHeaders headers 
    handleRequest req

-- | Perform a DELETE request, given some headers, for the given resource.
deleteRequest :: Headers -> String -> IO ResponseData
deleteRequest headers url =
    makeDeleteRequest url (makeHeaders headers) >>= handleRequest

-- | Perform a POST request given request headers, a url, and request body.
postRequest :: Headers -> String -> String -> IO ResponseData
postRequest headers url body = do
    req <- makePostRequest url $ makeHeaders headers
    handleRequest $ req { requestBody = RequestBodyBS $ BS.pack body }

-- | Performs a multipart request file upload with the given parameters.
multipartRequest
    :: Headers    -- ^ Some headers, must include authorization.
    -> String     -- ^ Request URL.
    -> Parameters -- ^ Multipart parameters.
    -> String     -- ^ Post file path.
    -> String     -- ^ The boundary for each of the headers.
    -> IO ResponseData
multipartRequest headers url params path boundary = do
    let part0 = partFile (T.pack "file") path
        parts = makeMultipartParts params ++ [part0]
    req      <- parseUrl url >>= formDataBodyWithBoundary (BS.pack boundary) parts
    handleRequest $ req { requestHeaders = requestHeaders req ++ makeHeaders headers }
        

-- | Perform a PUT request given request headers, a url, and a request body.
putRequest :: Headers -> String -> String -> IO ResponseData
putRequest headers url body = do
    req <- makePutRequest url $ makeHeaders headers
    handleRequest $ req { requestBody = RequestBodyBS $ BS.pack body }

-- Handles a request and returns some response data.
handleRequest :: Request -> IO ResponseData
handleRequest req = do
    resp <- getResponse req
    return $ ResponseData 
        { headers = map showpair $ responseHeaders resp
        , body    = BSL.unpack   $ responseBody    resp
        , status  = statusCode   $ responseStatus  resp
        }
    where
    showpair (a, b) = (show a, show b)

-- Turns a request into a response.
getResponse :: Request -> IO (Response BSL.ByteString)
getResponse = withManager . httpLbs

-- * Headers and Parameters

-- | Makes a header out of a given header name and value tuple.
makeHeader :: (String, String) -> Header
makeHeader (key, val) = (toCI key, BS.pack val)
    where
    toCI = mk . foldCase . BS.pack

-- | Maps makeHeader to a list of header tuples.
makeHeaders :: Headers -> [Header]
makeHeaders = map makeHeader

-- | Returns a user agent tuple with the specified user agent.
makeUserAgentHeader :: String -> (String,String)
makeUserAgentHeader str = ("User-Agent"   , str)
-- | Returns an authorization tuple with the specified authorization string.
makeAuthHeader      :: String -> (String,String)
makeAuthHeader      str = ("Authorization", str)
-- | Returns a content type tuple with the specified content type.
makeContentHeader   :: String -> (String,String)
makeContentHeader   str = ("Content-Type" , str)

-- | Takes a url and appends the parameters to form a query url.
appendParams :: String -> Parameters -> String
appendParams url ((k,v):ps)
    | '?' `elem` url = appendParams (url ++ "&" ++ k ++ "=" ++ urlEncode v) ps
    | otherwise      = appendParams (url ++ "?" ++ k ++ "=" ++ urlEncode v) ps
appendParams url []  = url

-- | A map from String tuple to ByteString tuple.
strToBS :: (String,String) -> (BS.ByteString,BS.ByteString)
strToBS (a,b) = (BS.pack a,BS.pack b)

-- Functions that return a respectively formatted request.

-- Returns a get request given a url and some headers.
makeGetRequest :: String -> [Header] -> IO Request
makeGetRequest uri headers = do
    req <- parseUrl uri
    return $ req
        { requestHeaders = makeHeader contentHeader : headers
        }
    where
    contentHeader = makeContentHeader "application/x-www-form-urlencoded"

-- Makes the @makeGetRequest@ a DELETE request.
makeDeleteRequest :: String -> [Header] -> IO Request
makeDeleteRequest uri headers = do
    req <- makeGetRequest uri headers
    return $ req { method = BS.pack "DELETE" }

-- Makes the @makeRegularPostRequest@ a json POST request.
makePostRequest :: String -> [Header] -> IO Request
makePostRequest uri headers = do
    req <- makeRegularPostRequest uri headers
    return $ req
        { requestHeaders = (makeHeader $ makeContentHeader "application/json") 
                           : headers
        }

-- Makes the @makeGetRequest@ a POST request.
makeRegularPostRequest :: String -> [Header] -> IO Request
makeRegularPostRequest uri headers = do
    req <- makeGetRequest uri headers
    return $ req { method = BS.pack "POST" }

-- Makes the @makePostRequest@ a PUT request.
makePutRequest :: String -> [Header] -> IO Request
makePutRequest uri headers = do
    req <- makePostRequest uri headers
    return $ req { method = BS.pack "PUT" }

-- Makes a list of multipart parts given a list of parameters
makeMultipartParts :: Parameters -> [Part]
makeMultipartParts ((a,b):cs) = partBS (T.pack a) (BS.pack b) : makeMultipartParts cs
makeMultipartParts _          = []