{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- File   : Auth
-- Author : Alejandro Gómez Londoño
-- Date   : Sat Sep 13 18:19:45 2014
-- Description : Dropbox API Authorization function calls
--------------------------------------------------------------------------------
-- Change log :

--------------------------------------------------------------------------------
module MonadBox.Auth where

import Control.Lens ((&), (.~), (^.), (?~))
import qualified Data.Text.IO as Text
import qualified MonadBox.URI as URI
import MonadBox.Types (Code,DBToken(..),MonadConf(..),
                       ClientId,ClientSecret)
import Network.Wreq (FormParam((:=)), auth, basicAuth,
                     defaults, postWith, responseBody)
import Control.Exception (catch)
import Data.Text (append)
import Data.Text.Encoding (encodeUtf8)
import Data.Yaml (encodeFile)
import MonadBox.Exceptions (catchStatus,catchFile)
import MonadBox.Util (asJSON,caseM)
import System.Environment (getEnv)
import System.Exit (ExitCode(ExitFailure), exitWith)
import System.IO (hFlush, stdout)
import System.IO.Error (tryIOError)

-- | Start the authentication process with Dropbox
-- | and saves the token on the default path
generateConf ∷ IO MonadConf
generateConf =  do
  let δ = do
        _key    ← putStr "App Key: "    >> hFlush stdout >> Text.getLine
        _secret ← putStr "App Secret: " >> hFlush stdout >> Text.getLine
        Text.putStrLn "Authorize this app on :"
        Text.putStrLn $ URI.authorize `append` "client_id=" `append`
          _key `append` "&response_type=code&state=monadbox"
        _code   ← putStr "Code: "  >> hFlush stdout >> Text.getLine
        let _token = do r ← _DBToken _code _key _secret
                        return $ MonadConf (access_token r) _key _secret
        let _catch e = catchStatus e >> δ
        catch _token _catch
  conf ← δ
  path ← caseM (tryIOError $ getEnv "HOME")
               (\r → return $ r ++ "/.monadbox")
               (\_ → return ".monadbox")
  caseM (tryIOError $ encodeFile path conf)
        (\_ → return conf)
        (\e → do catchFile True e
                 putStrLn "Exiting..."
                 exitWith (ExitFailure 1))

_DBToken ∷ Code
         → ClientId
         → ClientSecret
         → IO DBToken
_DBToken code _id _secret = do
  let opts = defaults & auth ?~ basicAuth (encodeUtf8 _id) (encodeUtf8 _secret)
  let postVals = ["code"       := code ,
                  "grant_type" := ("authorization_code" :: String)]
  r ← asJSON =<< postWith opts URI.token postVals
  return $ r ^. responseBody
