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
pokitdokGetRequest
:: OAuth2
-> String
-> Parameters
-> IO ResponseData
pokitdokGetRequest key = getRequest headers
where headers = [bearerH . fromJust $ oauthAccessToken key, userAgentH]
pokitdokDeleteRequest
:: OAuth2
-> String
-> IO ResponseData
pokitdokDeleteRequest key = deleteRequest headers
where headers = [bearerH . fromJust $ oauthAccessToken key, userAgentH]
pokitdokPostRequest
:: OAuth2
-> String
-> String
-> IO ResponseData
pokitdokPostRequest key = postRequest headers
where headers = [bearerH . fromJust $ oauthAccessToken key, userAgentH]
pokitdokPutRequest
:: OAuth2
-> String
-> String
-> IO ResponseData
pokitdokPutRequest key = putRequest headers
where headers = [bearerH . fromJust $ oauthAccessToken key, userAgentH]
pokitdokMultipartRequest
:: OAuth2
-> String
-> Parameters
-> String
-> IO ResponseData
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)
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)
bearerH :: AccessToken -> (String, String)
bearerH (AccessToken token _ _ _ _) = makeAuthHeader $ "Bearer " ++ token
basicH :: OAuth2 -> (String, String)
basicH (OAuth2 id sec _ _ _ _) = makeAuthHeader $ "Basic "++B64.encode(id++":"++sec)
userAgentH :: (String, String)
userAgentH = makeUserAgentHeader $ "haskell-pokitdok/" ++ httpPackageVersion
getJSONIO :: ResponseData -> IO String
getJSONIO = return . getJSON
getJSON :: ResponseData -> String
getJSON (ResponseData _ body _) = body
activateKeyWithAuthCode :: OAuth2 -> String -> IO OAuth2
activateKeyWithAuthCode auth code = do
token <- authenticateAuthorizationCode headers auth code
return $ keyModAccessToken auth (Just token)
where headers = [basicH auth, userAgentH]
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]
isExpired' :: AccessToken -> IO Bool
isExpired' (AccessToken _ _ (Just exp) _ _) = getPOSIXTime >>=
(\now -> return $ (realToFrac now :: Float) > (fromIntegral exp :: Float) 5)
isExpired' _ = return False
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 ()