test.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

data Errors =
  SomeRandomError
  deriving (Show, Eq, Generic)

instance FromJSON Errors where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }


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

data FitbitUser = FitbitUser
    { userId   :: Text
    , userName :: Text
    , userAge  :: Int
    } deriving (Show, Eq)

instance FromJSON FitbitUser where
    parseJSON (Object o) =
        FitbitUser
        <$> ((o .: "user") >>= (.: "encodedId"))
        <*> ((o .: "user") >>= (.: "fullName"))
        <*> ((o .: "user") >>= (.: "age"))
    parseJSON _ = mzero

instance ToJSON FitbitUser where
    toJSON (FitbitUser fid name age) =
        object [ "id"       .= fid
               , "name"     .= name
               , "age"      .= age
               ]

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

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

state :: B.ByteString
state = "testFitbitApi"

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

getApiUser :: Manager -> AccessToken -> IO FitbitUser
getApiUser mgr token = do
    result <- authGetJSON mgr token [uri|https://api.fitbit.com/1/user/-/profile.json|]
    case result of
        Right user                     -> return user
        Left (e :: OAuth2Error Errors) -> Prelude.error $ show e

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)