hoauth2-1.6.3: example/demo-server.hs

{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import           Control.Monad            (mzero)
import qualified Data.ByteString          as B
import qualified Data.ByteString.Lazy     as BL
import           Data.Char                (chr)
import qualified Data.Map                 as M
import           Data.Text                (Text)
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as T
import           Network.HTTP.Conduit     hiding (Request, queryString)
import           Network.HTTP.Types       (Query, status200)
import           Network.Wai
import           Network.Wai.Handler.Warp (run)
import           URI.ByteString           (serializeURIRef')
import           URI.ByteString.QQ

import           Keys                     (fitbitKey)
import           Network.OAuth.OAuth2

import           Data.Aeson
import           Data.Aeson.Types
import           GHC.Generics

------------------------------------------------------------------------------

main :: IO ()
main = do
    print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey
    putStrLn "visit the url to continue"
    run 9988 application

application :: Application
application request respond = do
    response <- handleRequest requestPath request
    respond $ responseLBS status200 [("Content-Type", "text/plain")] response
  where
    requestPath = T.intercalate "/" $ pathInfo request

handleRequest :: Text -> Request -> IO BL.ByteString
handleRequest "favicon.ico" _ = return ""
handleRequest _ request = do
    mgr <- newManager tlsManagerSettings
    token <- getApiToken mgr $ getApiCode request
    print token
    user <- getApiUser mgr (accessToken token)
    print user
    return $ encode user

getApiCode :: Request -> ExchangeToken
getApiCode request =
    case M.lookup "code" queryMap of
        Just code -> ExchangeToken $ T.decodeUtf8 code
        Nothing   -> Prelude.error "request doesn't include code"
  where
    queryMap = convertQueryToMap $ queryString request

getApiToken :: Manager -> ExchangeToken -> IO OAuth2Token
getApiToken mgr code = do
    result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)]
    case result of
        Right token                    -> return token
        Left (e :: OAuth2Error Errors) -> Prelude.error $ show e
  where
    (url, body) = accessTokenUrl fitbitKey code

convertQueryToMap :: Query -> M.Map B.ByteString B.ByteString
convertQueryToMap query =
    M.fromList $ map normalize query
  where
    normalize (k, Just v)  = (k, v)
    normalize (k, Nothing) = (k, B.empty)

lazyBSToString :: BL.ByteString -> String
lazyBSToString s = map (chr . fromIntegral) (BL.unpack s)