Move Facebook to Text

Web/Authenticate/Facebook.hs

@@ -1,6 +1,12 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-module Web.Authenticate.Facebook where
+{-# LANGUAGE OverloadedStrings #-}
+module Web.Authenticate.Facebook
+    ( Facebook (..)
+    , getForwardUrl
+    , getAccessToken
+    , getGraphData
+    ) where
 
 import Network.HTTP.Enumerator
 import Data.List (intercalate)
@@ -12,64 +18,72 @@ import Data.Typeable (Typeable)
 import Control.Exception (Exception, throwIO)
 import Data.Attoparsec.Lazy (parse, eitherResult)
 import qualified Data.ByteString.Char8 as S8
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Blaze.ByteString.Builder (toByteString, copyByteString)
+import Blaze.ByteString.Builder.Char.Utf8 (fromText)
+import Network.HTTP.Types (renderQueryText)
+import Data.Monoid (mappend)
+import Data.ByteString (ByteString)
 
 data Facebook = Facebook
-    { facebookClientId :: String
+    { facebookClientId :: Text
-    , facebookClientSecret :: String
+    , facebookClientSecret :: Text
-    , facebookRedirectUri :: String
+    , facebookRedirectUri :: Text
     }
     deriving (Show, Eq, Read, Ord, Data, Typeable)
 
-newtype AccessToken = AccessToken { unAccessToken :: String }
+newtype AccessToken = AccessToken { unAccessToken :: Text }
     deriving (Show, Eq, Read, Ord, Data, Typeable)
 
-getForwardUrl :: Facebook -> [String] -> String
+getForwardUrl :: Facebook -> [Text] -> Text
-getForwardUrl fb perms = concat
+getForwardUrl fb perms =
-    [ "https://graph.facebook.com/oauth/authorize?client_id="
+    TE.decodeUtf8 $ toByteString $
-    , qsEncode $ facebookClientId fb
+    copyByteString "https://graph.facebook.com/oauth/authorize"
-    , "&redirect_uri="
+    `mappend`
-    , qsEncode $ facebookRedirectUri fb
+    renderQueryText True
-    , if null perms
+        ( ("client_id", Just $ facebookClientId fb)
-        then ""
+        : ("redirect_uri", Just $ facebookRedirectUri fb)
-        else "&scope=" ++ qsEncode (intercalate "," perms)
+        : if null perms
-    ]
+            then []
+            else [("scope", Just $ T.intercalate "," perms)])
 
-accessTokenUrl :: Facebook -> String -> String
-accessTokenUrl fb code = concat
-    [ "https://graph.facebook.com/oauth/access_token?client_id="
-    , qsEncode $ facebookClientId fb
-    , "&redirect_uri="
-    , qsEncode $ facebookRedirectUri fb
-    , "&client_secret="
-    , qsEncode $ facebookClientSecret fb
-    , "&code="
-    , qsEncode code
-    ]
 
-getAccessToken :: Facebook -> String -> IO AccessToken
+accessTokenUrl :: Facebook -> Text -> ByteString
+accessTokenUrl fb code =
+    toByteString $
+    copyByteString "https://graph.facebook.com/oauth/access_token"
+    `mappend`
+    renderQueryText True
+        [ ("client_id", Just $ facebookClientId fb)
+        , ("redirect_uri", Just $ facebookRedirectUri fb)
+        , ("code", Just code)
+        ]
+
+getAccessToken :: Facebook -> Text -> IO AccessToken
 getAccessToken fb code = do
     let url = accessTokenUrl fb code
-    b <- simpleHttp $ S8.pack url
+    b <- simpleHttp url
     let (front, back) = splitAt 13 $ L8.unpack b
     case front of
-        "access_token=" -> return $ AccessToken back
+        "access_token=" -> return $ AccessToken $ T.pack back
         _ -> error $ "Invalid facebook response: " ++ back
 
-graphUrl :: AccessToken -> String -> String
+graphUrl :: AccessToken -> Text -> ByteString
-graphUrl (AccessToken s) func = concat
+graphUrl (AccessToken s) func =
-    [ "https://graph.facebook.com/"
+    toByteString $
-    , func
+    copyByteString "https://graph.facebook.com/"
-    , "?access_token="
+    `mappend` fromText func
-    , s
+    `mappend` renderQueryText True [("access_token", Just s)]
-    ]
 
-getGraphData :: AccessToken -> String -> IO (Either String Value)
+getGraphData :: AccessToken -> Text -> IO (Either String Value)
 getGraphData at func = do
     let url = graphUrl at func
-    b <- simpleHttp $ S8.pack url
+    b <- simpleHttp url
     return $ eitherResult $ parse json b
 
-getGraphData' :: AccessToken -> String -> IO Value
+getGraphData' :: AccessToken -> Text -> IO Value
 getGraphData' a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return
 
 data InvalidJsonException = InvalidJsonException String

facebook.hs

@@ -1,14 +1,18 @@
-{-# LANGUAGE TypeFamilies, QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 import Yesod
 import Web.Authenticate.Facebook
-import Data.Object
 import Data.Maybe (fromMaybe)
 import Network.HTTP.Enumerator
+import Data.Text (pack)
+import qualified Data.Aeson as A
+import qualified Data.Vector as V
+import qualified Data.Map as M
+import Data.Text.Encoding (encodeUtf8)
 
 data FB = FB Facebook
 fb :: FB
 fb = FB $ Facebook "134280699924829" "a7685e10c8977f5435e599aaf1d232eb"
-                   "http://localhost:3000/facebook/"
+                   "http://localhost:3000/facebook"
 mkYesod "FB" [$parseRoutes|
 / RootR GET
 /facebook FacebookR GET
@@ -18,40 +22,41 @@ instance Yesod FB where approot _ = "http://localhost:3000"
 
 getRootR = do
     FB f <- getYesod
-    redirectString RedirectTemporary $ getForwardUrl f ["email"]
+    let s = encodeUtf8 $ getForwardUrl f ["email"]
+    redirectString RedirectTemporary s
     return ()
 
 getFacebookR = do
     FB f <- getYesod
     code <- runFormGet' $ stringInput "code"
-    at <- liftIO $ getAccessToken f code
+    at <- liftIO $ getAccessToken f $ pack code
     mreq <- runFormGet' $ maybeStringInput "req"
     let req = fromMaybe "me" mreq
-    so <- liftIO $ getGraphData at req
+    Right so <- liftIO $ getGraphData at $ pack req
     let so' = objToHamlet so
-    hamletToRepHtml [$hamlet|
+    hamletToRepHtml [$hamlet|\
-%form
+<form>
-    %input!type=hidden!name=code!value=$string.code$
+    <input type="hidden" name="code" value="#{string code}">
-    Request: $
+    \Request: 
-    %input!type=text!name=req!value=$string.req$
+    <input type="text" name="req" value="#{string req}">
-    \ $
+    \ 
-    %input!type=submit
+    <input type="submit">
-%hr
+<hr>
-^so'^
+\^{so'}
 |]
 
-main = withHttpEnumerator $ basicHandler 3000 fb
+main = warpDebug 3000 fb
 
-objToHamlet :: StringObject -> Hamlet url
+objToHamlet :: A.Value -> Hamlet url
-objToHamlet (Scalar s) = [$hamlet|$string.s$|]
+objToHamlet (A.String s) = [$hamlet|#{s}|]
-objToHamlet (Sequence list) = [$hamlet|
+objToHamlet (A.Array list) = [$hamlet|
-%ul
+<ul>
-    $forall list o
+    $forall o <- V.toList list
-        %li ^objToHamlet.o^
+        <li>^{objToHamlet o}
 |]
-objToHamlet (Mapping pairs) = [$hamlet|
+objToHamlet (A.Object pairs) = [$hamlet|\
-%dl
+<dl>
-    $forall pairs pair
+    $forall pair <- M.toList pairs
-        %dt $string.fst.pair$
+        <dt>#{fst pair}
-        %dd ^objToHamlet.snd.pair^
+        <dd>^{objToHamlet $ snd pair}
 |]