{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Google.OAuth2
    ( getToken
    , OAuth2Client(..)
    , Scope
    , AccessToken
    ) where

import Control.Concurrent
import Control.Exception (onException, throwIO)
import Control.Monad (join)
import Data.Aeson
import qualified Data.ByteString.Char8 as B
import Data.Monoid ((<>))
import Data.Time
import Network.HTTP.Types (renderSimpleQuery, status200)
import Network.HTTP.Req
import Network.Wai
import Network.Wai.Handler.Warp
import System.Directory
import System.Exit
import System.FilePath
import System.IO (hPutStrLn, stderr)

getToken :: OAuth2Client -> FilePath -> [Scope] -> IO AccessToken
getToken c tokenFile scopes = do
    b <- doesFileExist tokenFile
    if b then readToken c tokenFile else downloadToken c tokenFile scopes

readToken :: OAuth2Client -> FilePath -> IO AccessToken
readToken c tokenFile = do
    t <- read <$> readFile tokenFile
    let e = fromIntegral $ expiresIn t - 5
    now <- getCurrentTime
    mt <- getModificationTime tokenFile
    if now < addUTCTime e mt
       then return $ B.pack $ accessToken t
       else do
           t' <- getNewTokenInfo c (refreshToken t)
           saveTokenInfo tokenFile t'
           return $ B.pack $ accessToken t'

getNewTokenInfo :: OAuth2Client -> RefreshToken -> IO TokenInfo
getNewTokenInfo c rt = do
    let body = ReqBodyUrlEnc $
                   "refresh_token" =: rt <>
                   "client_id" =: clientId c <>
                   "client_secret" =: clientSecret c <>
                   "grant_type" =: ("refresh_token" :: String)
    res <- req POST tokenUrl body jsonResponse mempty
    let t' = responseBody res
    return $ t' { refreshToken = rt }

saveTokenInfo :: FilePath -> TokenInfo -> IO ()
saveTokenInfo tokenFile t = do
    createDirectoryIfMissing True $ takeDirectory tokenFile
    writeFile tokenFile (show t)

downloadToken :: OAuth2Client -> FilePath -> [Scope] -> IO AccessToken
downloadToken c tokenFile scopes = do
    code <- getCode c scopes
    t <- exchangeCode c code
    saveTokenInfo tokenFile t
    return $ B.pack $ accessToken t

getCode :: OAuth2Client -> [Scope] -> IO Code
getCode c scopes = do
    let authUri = "https://accounts.google.com/o/oauth2/v2/auth"
        q = renderSimpleQuery True
                [ ("scope", B.pack $ unwords scopes)
                , ("redirect_uri", B.pack redirectUri)
                , ("response_type", "code")
                , ("client_id", B.pack $ clientId c)
                ]
    putStrLn "Open the following uri in your browser:"
    putStrLn $ B.unpack $ authUri <> q
    m <- newEmptyMVar
    _ <- forkIO $ run serverPort (app m)
            `onException` do
                hPutStrLn stderr $ "Unable to use port " ++ show serverPort
                putMVar m Nothing
    mc <- takeMVar m
    case mc of
         Nothing -> die "Unable to get code"
         Just code -> return code

app :: MVar (Maybe Code) -> Application
app m request respond = do
    putMVar m $ B.unpack <$> join (lookup "code" $ queryString request)
    respond $ responseLBS status200
                          [("Content-Type", "text/plain")]
                          "Return your app"

exchangeCode :: OAuth2Client -> Code -> IO TokenInfo
exchangeCode c code = do
    let body = ReqBodyUrlEnc $
                   "code" =: code <>
                   "client_id" =: clientId c <>
                   "client_secret" =: clientSecret c <>
                   "redirect_uri" =: redirectUri <>
                   "grant_type" =: ("authorization_code" :: String)
    res <- req POST tokenUrl body jsonResponse mempty
    return $ responseBody res

tokenUrl :: Url 'Https
tokenUrl = https "accounts.google.com" /: "o" /: "oauth2" /: "token"

serverPort :: Port
serverPort = 8017

redirectUri :: String
redirectUri = "http://127.0.0.1:" ++ show serverPort

data OAuth2Client = OAuth2Client
    { clientId :: String
    , clientSecret :: String
    } deriving (Show, Read)

type AccessToken = B.ByteString
type RefreshToken = String
type Code = String

type Scope = String

data TokenInfo = TokenInfo
    { accessToken :: String
    , refreshToken :: String
    , expiresIn :: Int
    } deriving (Show, Read)

instance FromJSON TokenInfo where
    parseJSON (Object v) = TokenInfo <$> v .: "access_token"
                                     <*> v .:? "refresh_token" .!= ""
                                     <*> v .: "expires_in"
    parseJSON _ = mempty

instance MonadHttp IO where
  handleHttpException = throwIO