Haskell Servant OAuth2.0 for GitHub

oauth.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}

module Sand where

import Data.Aeson
import Data.Aeson.Types (parseEither, parse)
import qualified Data.HashMap.Strict as HM

import qualified Data.Text as T  
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.ByteString.Lazy (toChunks)

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class

import Servant
import Data.Proxy
import Network.Wai.Handler.Warp
import Network.HTTP.Media ((//), (/:))

import Network.HTTP.Simple hiding (Proxy)

{-

oauth.cabal
...
  build-depends:       base >= 4.7 && < 5
                     , aeson
                     , conduit
                     , bytestring                    
                     , http-media
                     , http-conduit
                     , unordered-containers
                     , text
                     , servant
                     , servant-server
                     , warp
...

TODO: include `state` in github request
TODO: clear up Strings/ByteStrings/Text that should be overloaded

-}

gh = OAuth2 {oauthClientId = "<create @ https://github.com/settings/applications/new>"
            , oauthClientSecret = "<create @ https://github.com/settings/applications/new>"
            , oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize"
            , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
            , oauthCallback = "http://localhost:8080/authorized"}

data OAuth2 = OAuth2 { oauthClientId :: String
                     , oauthClientSecret :: String
                     , oauthOAuthorizeEndpoint :: String
                     , oauthAccessTokenEndpoint :: String
                     , oauthCallback :: String
                     } deriving (Show, Eq)

----------

authEndpoint :: OAuth2 -> String
authEndpoint oa = concat [(oauthOAuthorizeEndpoint oa)
                           , "?client_id=", (oauthClientId oa)
                           , "&response_type=", "code"
                           , "&redirect_uri=", (oauthCallback oa)]

tokenEndpoint :: String -> OAuth2 -> String
tokenEndpoint code oa = concat [(oauthAccessTokenEndpoint oa)
                                 , "?client_id=", (oauthClientId oa)
                                 , "&client_secret=", (oauthClientSecret oa)
                                 , "&code=", code]

----------

-- Step 1. Take user to the service's auth page
getAuthorize :: Handler HTML
getAuthorize = return $ concat ["<h1><a href=", authEndpoint gh, ">", "Get Authorized!", "</a></h1>"]

-- Step 2. Accept a temporary code from the service
getAuthorized :: Maybe String -> Handler HTML
getAuthorized mcode = do
  case mcode of
    Nothing -> error "You must pass in a code as a parameter"
    Just code -> do
      token <- liftIO $ getAccessToken code
      return $ case token of
        Nothing ->  "<h1>Error Fetching Token</h1>"
        Just t -> concat ["<h1>Your Token Is:</h1>"
                         , "<h3>" , t , "</h3>"]

-- Step 3. Exchange code for auth token
getAccessToken :: String -> IO (Maybe String)
getAccessToken code = do
  let endpoint = tokenEndpoint code gh
  request' <- parseRequest endpoint
  let request = setRequestMethod "POST"
                $ addRequestHeader "Accept" "application/json"
                $ setRequestQueryString [("client_id", Just . B8.pack . oauthClientId $ gh)
                                        , ("client_secret", Just . B8.pack . oauthClientSecret $ gh)
                                        , ("code", Just . B8.pack $ code)]
                $ request'
  response <- httpJSONEither request
  return $ case (getResponseBody response :: Either JSONException Object) of
             Left _ -> Nothing
             Right obj -> case HM.lookup "access_token" obj of
                            Just (String x) -> Just . T.unpack $ x
                            _ -> Nothing
                            
----------

-- HTML Return Type for returning Strings as HTML
type HTML = String
instance Accept HTML where
  contentType _ = "text" // "html" /: ("charset", "utf-8")
instance MimeRender HTML String where
  mimeRender _ = L8.pack
  
type API = "authorize" :> Get '[HTML] HTML
           :<|> "authorized" :> QueryParam "code" String :> Get '[HTML] HTML

----------

api :: Proxy API
api = Proxy

server :: Server API
server = getAuthorize
         :<|> getAuthorized

----------

main = do
  putStrLn "Visit http://localhost:8080/authorize"
  run 8080 (serve api server)

FYI: I packaged this up in a way I found pleasing at https://github.com/TomMD/oauth2-simple