Handler.hs

{-# LANGUAGE OverloadedStrings #-}
module DarcsDen.Google.Handler where

import Prelude hiding (concat)
import Control.Monad.Trans (liftIO)
import Data.ByteString.Char8 (pack)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Maybe (fromJust)
import Data.List (elemIndices)
import Network.HTTP.Conduit (requestHeaders, urlEncodedBody, responseBody, withManager, httpLbs)
import Snap.Core (Snap)
import Text.JSON (decode, Result(..), fromJSObject, fromJSString, JSObject, JSValue(..))
import qualified Codec.Binary.Base64.String as B64

import DarcsDen.WebUtils (input)
import DarcsDen.Google.Util (getGoogleClientId, getGoogleClientSecret)
import DarcsDen.Google.Paths
import DarcsDen.Settings

getSubAndEmail :: String -> Snap (String, String)
getSubAndEmail ruri = do
   cd <- fmap pack (input "code" "no-code")
   cid <- fmap pack getGoogleClientId
   cs <- fmap pack getGoogleClientSecret
   let request = (urlEncodedBody 
                 [  ("code", cd)
                 , ("client_id", cid)
                 , ("client_secret", cs)
                 , ("redirect_uri", pack $ baseUrl ++ ruri ++ "/google/response")
                 , ("grant_type", "authorization_code")
                 ] googleAccessTokenRequest)
                    { requestHeaders = [("Content-Type", "application/x-www-form-urlencoded")] }
   response <- fmap responseBody $ liftIO $ withManager $ httpLbs request
   let Ok jo = decode (unpack response) :: Result (JSObject JSValue) 
       val = (\(JSString jstr) -> fromJSString jstr) $ fromJust $ lookup "id_token" (fromJSObject jo)
       [ps1, ps2] = elemIndices '.' val
   liftIO $ putStrLn val
   let Ok jo' = decode $ decodeUFB64 $ drop (ps1+1) $ take ps2 val :: Result (JSObject JSValue)
       sub = (\(JSString jstr) -> fromJSString jstr) $ fromJust $ lookup "sub" (fromJSObject jo')
       email = (\(JSString jstr) -> fromJSString jstr) $ fromJust $ lookup "email" (fromJSObject jo')
   return (sub, email)

-- decode Base 64 Encoding with URL and Filename Safe Alphabet, with padding removed
decodeUFB64 :: String -> String
decodeUFB64 xs' = B64.decode str
   where xs = foldr f [] xs'
         str = xs ++ replicate (mod (4 - mod (length xs) 4) 4) '='

         f :: Char -> String -> String
         f '-' ys = '+':ys
         f '_' ys = '/':ys
         f chr ys = chr:ys