Handler.hs

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

import Prelude hiding (concat)
import Control.Monad.Trans (liftIO)
import Data.ByteString.Char8 (append, pack)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Maybe (fromJust)
import Data.List (find)
import Network.HTTP.Conduit (requestHeaders, queryString, urlEncodedBody, responseBody, withManager, httpLbs)
import Snap.Core (Snap)
import Text.JSON (decode, Result(..), fromJSObject, JSValue(..), JSObject, fromJSString)

import DarcsDen.WebUtils (input)
import DarcsDen.Github.Util (getGId, getGPwd)
import DarcsDen.Github.Paths

getAccessToken :: Snap String
getAccessToken = do
   cd <- fmap pack (input "code" "no-code")
   cid <- fmap pack getGId
   cs <- fmap pack getGPwd
   let request = (urlEncodedBody
                    [  ("client_id", cid)
                    ,  ("client_secret", cs)
                    , ("code", cd)
                    ]
                    githubAccessTokenRequest)
                     { requestHeaders = 
                          [ ("Accept", "application/json")
                          , ("User-Agent", "darcsden")
                          , ("Content-Type", "application/x-www-form-urlencoded")
                          ] 
                     }
   response <- fmap responseBody $ liftIO $ withManager $ httpLbs request
   let Ok jo = decode (unpack response)
       access_token = fromJust $ lookup "access_token" (fromJSObject jo)
   return access_token

getLoginID :: String -> Snap String
getLoginID access_token = do
   let request = githubAuthUserRequest
                  {  queryString = append "access_token=" (pack access_token) 
                  ,  requestHeaders = 
                          [ ("Accept", "application/json")
                          , ("User-Agent", "darcsden")
                          ] 
                  }
   response <- fmap responseBody $ liftIO $ withManager $ httpLbs request
   let Ok jo = decode (unpack response) :: Result (JSObject JSValue)
       JSString login = fromJust $ lookup "login" (fromJSObject jo)
   return (fromJSString login)

getEmailID :: String -> Snap String 
getEmailID access_token = do
   let request = githubEmailRequest
                    { requestHeaders = [ ("Accept", "application/vnd.github.v3+json")
                                       , ("User-Agent", "darcsden")
                                       ]
                    , queryString = append "access_token=" (pack access_token)
                    }
   response <- fmap responseBody $ liftIO $ withManager $ httpLbs request
   let Ok ja = decode (unpack response) :: Result [JSObject JSValue]
       JSString email = fromJust.lookup "email".fromJSObject.fromJust $ find ((==Just (JSBool True)).lookup "primary".fromJSObject) ja
   return (fromJSString email)

getKeys :: String -> Snap [String]
getKeys access_token = do
   let request = githubKeysRequest { queryString = append "access_token=" (pack access_token)
                                   , requestHeaders = 
                                       [ ("Accept", "application/json")
                                       , ("User-Agent", "darcsden")
                                       ]
                                   }
   response <- fmap responseBody $ liftIO $ withManager $ httpLbs request
   let Ok ja = decode (unpack response) :: Result [JSObject JSValue]
   return $ map (fromJSString.(\(JSString x) -> x).fromJust.lookup "key".fromJSObject) ja