Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Haskell Servant OAuth2.0 for GitHub
{-# 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)
@TomMD

This comment has been minimized.

Copy link

TomMD commented Jan 17, 2018

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.