pokitdok-4.1.0.1: PokitDok/Requests.hs

-- | This module bridges the minimal calls in the
--   Client module, adds specific headers required by
--   the API, and passes them to the more generic calls
--   of the OAuth2 module.
--
--   It also includes auxiliary funtions for handling
--   its main return type: @ResponseData@.

module PokitDok.Requests
    ( pokitdokGetRequest
    , pokitdokDeleteRequest
    , pokitdokPostRequest
    , pokitdokPutRequest
    , pokitdokMultipartRequest
    , activateKeyWithAuthCode
    , refreshExpired
    , isExpired'
    , assertValid
    , getJSONIO
    ) where

import qualified Codec.Binary.Base64.String as B64
import qualified System.IO.Strict           as SIO
import System.Directory (getCurrentDirectory)
import System.Info (os)
import Data.Time.Clock
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Time.Calendar (fromGregorian)
import Data.Maybe (fromJust)
import Data.Hex (hex)
import Network.HTTP.Base (httpPackageVersion)

import PokitDok.OAuth2

-- * Middleman Network Calls

-- | Sends a GET request to the server with the given query parameters.
pokitdokGetRequest
    :: OAuth2          -- ^ An OAuth2 credential.
    -> String          -- ^ The request url path.
    -> Parameters      -- ^ The query parameters.
    -> IO ResponseData -- ^ The response from the server.
pokitdokGetRequest key = getRequest headers
    where headers = [bearerH . fromJust $ oauthAccessToken key, userAgentH]

-- | Sends a DELETE request to the server with the given query parameters.
pokitdokDeleteRequest
    :: OAuth2          -- ^ A credential.
    -> String          -- ^ The request url path.
    -> IO ResponseData -- ^ Response from the server.
pokitdokDeleteRequest key = deleteRequest headers
    where headers = [bearerH . fromJust $ oauthAccessToken key, userAgentH]

-- | Sends a POST request to the server and posts the json string.
pokitdokPostRequest
    :: OAuth2          -- ^ Credentials.
    -> String          -- ^ The request url path.
    -> String          -- ^ JSON object String.
    -> IO ResponseData -- ^ Response from the server.
pokitdokPostRequest key = postRequest headers
    where headers = [bearerH . fromJust $ oauthAccessToken key, userAgentH]

-- | Sends a PUT request with JSON data.
pokitdokPutRequest
    :: OAuth2          -- ^ Credentials.
    -> String          -- ^ The request url path.
    -> String          -- ^ A JSON object String.
    -> IO ResponseData -- ^ Response from the server.
pokitdokPutRequest key = putRequest headers
    where headers = [bearerH . fromJust $ oauthAccessToken key, userAgentH]

-- | A multipart request that uploads a file.
pokitdokMultipartRequest
    :: OAuth2          -- ^ Credentials.
    -> String          -- ^ The request url path.
    -> Parameters      -- ^ Post data.
    -> String          -- ^ File system path of file to be posted.
    -> IO ResponseData -- ^ Response from the server.
pokitdokMultipartRequest auth url params pPath = do
    postPath <- format pPath
    boundary <- multipartBoundary
    multipartRequest headers url params postPath boundary
    where
    headers = [bearerH . fromJust $ oauthAccessToken auth, userAgentH]
    osChar =
        if os == "mingw"
        then '\\'
        else '/'
    format file@('C':_) = return file
    format file@('/':_) = return file
    format file = getCurrentDirectory >>= return . (++ [osChar] ++ file)

-- * Auxiliary Functions

-- The boundary of the PD multipart file upload.
multipartBoundary :: IO String
multipartBoundary = do
    now <- getCurrentTime
    let day0          = UTCTime { utctDay = fromGregorian 0001 01 01
                                , utctDayTime = 0
                                }
        ticks         = floor $ (realToFrac $ diffUTCTime now day0) * 10000000
    return $ "----------------------------" ++ (hex $ show ticks)

-- The bearer authorization header as a String tuple, given an AccessToken.
bearerH    :: AccessToken -> (String, String)
bearerH (AccessToken token _ _ _ _) = makeAuthHeader $ "Bearer " ++ token

-- The basic authorization header as a String tuple, given an OAuth2.
basicH     :: OAuth2      -> (String, String)
basicH (OAuth2 id sec _ _ _ _)      = makeAuthHeader $ "Basic "++B64.encode(id++":"++sec)

-- The pokitdok-haskell user agent header, as a String tuple.
userAgentH :: (String, String)
userAgentH = makeUserAgentHeader $ "haskell-pokitdok/" ++ httpPackageVersion

-- | Pulls the JSON response @String@ from a @ResponseDat@um,
--   and lifts the result to an IO monad.
getJSONIO :: ResponseData -> IO String
getJSONIO = return . getJSON

-- Extracts the JSON response from ResponseData.
getJSON :: ResponseData -> String
getJSON (ResponseData _ body _) = body


-- * Supplementary Client Functions

-- | Takes an @OAuth2@ & an authorization code,
--   and returns an @OAuth2@ with a refreshed @AccessToken@.
activateKeyWithAuthCode :: OAuth2 -> String -> IO OAuth2
activateKeyWithAuthCode auth code = do
    token <- authenticateAuthorizationCode headers auth code
    return $ keyModAccessToken auth (Just token)
    where headers = [basicH auth, userAgentH]

-- | Refreshes an @OAuth2@'s token given whether or not it is expired.
refreshExpired :: OAuth2 -> Bool -> IO OAuth2
refreshExpired auth False = return auth
refreshExpired auth@(OAuth2 _ _ _ _ _ (Just (AccessToken _ (Just _) _ _ _))) _ = do
    token <- authenticateRefreshToken headers auth
    return $ keyModAccessToken auth (Just token)
    where headers = [basicH auth, userAgentH]
refreshExpired auth _ = do
    token <- authenticateClientCredentials headers auth
    return $ keyModAccessToken auth (Just token)
    where headers = [basicH auth, userAgentH]

-- | Checks if the given @AccessToken@ is expired.
isExpired' :: AccessToken -> IO Bool
isExpired' (AccessToken _ _ (Just exp) _ _) = getPOSIXTime >>=
    (\now -> return $ (realToFrac now :: Float) > (fromIntegral exp :: Float) - 5) -- 5 sec timeout
isExpired' _ = return False

-- | Asserts that the given @OAuth2@ is valid to make a call.
assertValid :: OAuth2 -> IO ()
assertValid (OAuth2 _ _ _ _ _ Nothing)  = error "Access token has not been initialized."
assertValid (OAuth2 _ _ _ _ _ (Just t)) = do
    dead <- isExpired' t
    if dead then error "Access token is expired." else return ()