Cleanup, use SinglePiece

Yesod/Helpers/Auth.hs

@@ -22,20 +22,13 @@ module Yesod.Helpers.Auth
     , requireAuth
     ) where
 
-import Yesod.Handler
 import Yesod.Core
-import Yesod.Widget
-import Yesod.Content
-import Yesod.Dispatch
 import Yesod.Persist
-import Yesod.Request
 import Yesod.Json
 import Text.Blaze
 import Language.Haskell.TH.Syntax hiding (lift)
-import qualified Data.ByteString.Char8 as S8
 import qualified Network.Wai as W
 import Text.Hamlet (hamlet)
-import Data.Text.Lazy (pack)
 import qualified Data.Map as Map
 import Control.Monad.Trans.Class (lift)
 import Data.Aeson
@@ -66,7 +59,7 @@ data Creds m = Creds
     , credsExtra :: [(Text, Text)]
     }
 
-class Yesod m => YesodAuth m where
+class (Yesod m, SinglePiece (AuthId m)) => YesodAuth m where
     type AuthId m
 
     -- | Default destination on successful login, if no other
@@ -79,65 +72,62 @@ class Yesod m => YesodAuth m where
 
     getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
 
-    showAuthId :: m -> AuthId m -> Text
-    readAuthId :: m -> Text -> Maybe (AuthId m)
-
     authPlugins :: [AuthPlugin m]
 
     -- | What to show on the login page.
     loginHandler :: GHandler Auth m RepHtml
     loginHandler = defaultLayout $ do
-        setTitle $ string "Login"
+        setTitle "Login"
         tm <- lift getRouteToMaster
         mapM_ (flip apLogin tm) authPlugins
 
     ----- Message strings. In theory in the future make this localizable
     ----- See gist: https://gist.github.com/778712
     messageNoOpenID :: m -> Html
-    messageNoOpenID _ = string "No OpenID identifier found"
+    messageNoOpenID _ = "No OpenID identifier found"
     messageLoginOpenID :: m -> Html
-    messageLoginOpenID _ = string "Login via OpenID"
+    messageLoginOpenID _ = "Login via OpenID"
 
     messageEmail :: m -> Html
-    messageEmail _ = string "Email"
+    messageEmail _ = "Email"
     messagePassword :: m -> Html
-    messagePassword _ = string "Password"
+    messagePassword _ = "Password"
     messageRegister :: m -> Html
-    messageRegister _ = string "Register"
+    messageRegister _ = "Register"
     messageRegisterLong :: m -> Html
-    messageRegisterLong _ = string "Register a new account"
+    messageRegisterLong _ = "Register a new account"
     messageEnterEmail :: m -> Html
-    messageEnterEmail _ = string "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
+    messageEnterEmail _ = "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
     messageConfirmationEmailSentTitle :: m -> Html
-    messageConfirmationEmailSentTitle _ = string "Confirmation e-mail sent"
+    messageConfirmationEmailSentTitle _ = "Confirmation e-mail sent"
     messageConfirmationEmailSent :: m -> Text -> Html
     messageConfirmationEmailSent _ email = toHtml $ mconcat
         ["A confirmation e-mail has been sent to ", email, "."]
     messageAddressVerified :: m -> Html
-    messageAddressVerified _ = string "Address verified, please set a new password"
+    messageAddressVerified _ = "Address verified, please set a new password"
     messageInvalidKeyTitle :: m -> Html
-    messageInvalidKeyTitle _ = string "Invalid verification key"
+    messageInvalidKeyTitle _ = "Invalid verification key"
     messageInvalidKey :: m -> Html
-    messageInvalidKey _ = string "I'm sorry, but that was an invalid verification key."
+    messageInvalidKey _ = "I'm sorry, but that was an invalid verification key."
     messageInvalidEmailPass :: m -> Html
-    messageInvalidEmailPass _ = string "Invalid email/password combination"
+    messageInvalidEmailPass _ = "Invalid email/password combination"
     messageBadSetPass :: m -> Html
-    messageBadSetPass _ = string "You must be logged in to set a password"
+    messageBadSetPass _ = "You must be logged in to set a password"
     messageSetPassTitle :: m -> Html
-    messageSetPassTitle _ = string "Set password"
+    messageSetPassTitle _ = "Set password"
     messageSetPass :: m -> Html
-    messageSetPass _ = string "Set a new password"
+    messageSetPass _ = "Set a new password"
     messageNewPass :: m -> Html
-    messageNewPass _ = string "New password"
+    messageNewPass _ = "New password"
     messageConfirmPass :: m -> Html
-    messageConfirmPass _ = string "Confirm"
+    messageConfirmPass _ = "Confirm"
     messagePassMismatch :: m -> Html
-    messagePassMismatch _ = string "Passwords did not match, please try again"
+    messagePassMismatch _ = "Passwords did not match, please try again"
     messagePassUpdated :: m -> Html
-    messagePassUpdated _ = string "Password updated"
+    messagePassUpdated _ = "Password updated"
 
     messageFacebook :: m -> Html
-    messageFacebook _ = string "Login with Facebook"
+    messageFacebook _ = "Login with Facebook"
 
 type Texts = [Text]
 
@@ -180,14 +170,14 @@ setCreds doRedirects creds = do
 |]
                             sendResponse rh
                         Just ar -> do
-                            setMessage $ string "Invalid login"
+                            setMessage "Invalid login"
                             redirect RedirectTemporary ar
                 else return ()
         Just aid -> do
-            setSession credsKey $ showAuthId y aid
+            setSession credsKey $ toSinglePiece aid
             if doRedirects
                 then do
-                    setMessage $ string "You are now logged in"
+                    setMessage "You are now logged in"
                     redirectUltDest RedirectTemporary $ loginDest y
                 else return ()
 
@@ -195,8 +185,8 @@ getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
 getCheckR = do
     creds <- maybeAuthId
     defaultLayoutJson (do
-        setTitle $ string "Authentication Status"
-        addHtml $ html creds) (json creds)
+        setTitle "Authentication Status"
+        addHtml $ html creds) (json' creds)
   where
     html creds =
 #if GHC7
@@ -210,7 +200,7 @@ $maybe _ <- creds
 $nothing
     <p>Not logged in.
 |]
-    json creds =
+    json' creds =
         Object $ Map.fromList
             [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
             ]
@@ -239,10 +229,9 @@ handlePluginR plugin pieces = do
 maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
 maybeAuthId = do
     ms <- lookupSession credsKey
-    y <- getYesod
     case ms of
         Nothing -> return Nothing
-        Just s -> return $ readAuthId y s
+        Just s -> return $ fromSinglePiece s
 
 maybeAuth :: ( YesodAuth m
              , Key val ~ AuthId m

Yesod/Helpers/Auth/Email.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Helpers.Auth.Email
     ( -- * Plugin
       authEmail
@@ -55,12 +56,9 @@ data EmailCreds m = EmailCreds
     , emailCredsVerkey :: Maybe VerKey
     }
 
-class YesodAuth m => YesodAuthEmail m where
+class (YesodAuth m, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where
     type AuthEmailId m
 
-    showAuthEmailId :: m -> AuthEmailId m -> Text
-    readAuthEmailId :: m -> Text -> Maybe (AuthEmailId m)
-
     addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
     sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
     getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)
@@ -104,9 +102,8 @@ authEmail =
   where
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
-    dispatch "GET" ["verify", eid, verkey] = do
-        y <- getYesod
-        case readAuthEmailId y eid of
+    dispatch "GET" ["verify", eid, verkey] =
+        case fromSinglePiece eid of
             Nothing -> notFound
             Just eid' -> getVerifyR eid' verkey >>= sendResponse
     dispatch "POST" ["login"] = postLoginR >>= sendResponse
@@ -151,7 +148,7 @@ postRegisterR = do
                 return (lid, key)
     render <- getUrlRender
     tm <- getRouteToMaster
-    let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey
+    let verUrl = render $ tm $ verify (toSinglePiece lid) verKey
     sendVerifyEmail email verKey verUrl
     defaultLayout $ do
         setTitle $ messageConfirmationEmailSentTitle y

Yesod/Helpers/Auth/Facebook.hs

@@ -17,11 +17,11 @@ import Yesod.Handler
 import Yesod.Widget
 import Text.Hamlet (hamlet)
 import Control.Monad.IO.Class (liftIO)
-import qualified Data.ByteString.Char8 as S8
 import Control.Monad.Trans.Class (lift)
 import Data.Text (Text)
 import Control.Monad (mzero)
 import Data.Monoid (mappend)
+import qualified Data.Aeson.Types
 
 facebookUrl :: AuthRoute
 facebookUrl = PluginR "facebook" ["forward"]
@@ -39,7 +39,7 @@ authFacebook cid secret perms =
         tm <- getRouteToMaster
         render <- getUrlRender
         let fb = Facebook.Facebook cid secret $ render $ tm url
-        redirectString RedirectTemporary $ Facebook.getForwardUrl fb perms
+        redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms
     dispatch "GET" [] = do
         render <- getUrlRender
         tm <- getRouteToMaster
@@ -67,6 +67,7 @@ authFacebook cid secret perms =
     <a href="#{furl}">#{messageFacebook y}
 |]
 
+parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)
 parseCreds at' (Object m) = do
     id' <- m .: "id"
     let id'' = "http://graph.facebook.com/" `mappend` id'

Yesod/Helpers/Auth/HashDB.hs

@@ -73,7 +73,6 @@ import Text.Hamlet (hamlet)
 import Control.Applicative         ((<$>), (<*>))
 import Data.ByteString.Lazy.Char8  (pack)
 import Data.Digest.Pure.SHA        (sha1, showDigest)
-import Database.Persist.TH         (share2, mkMigrate, persist, mkPersist)
 import Data.Text                   (Text, unpack)
 import Data.Maybe                  (fromMaybe)
 

Yesod/Helpers/Auth/OAuth.hs

@@ -14,15 +14,14 @@ import Text.Hamlet (hamlet)
 import Web.Authenticate.OAuth
 import Data.Maybe
 import Data.String
-import Network.HTTP.Enumerator
 import Data.ByteString.Char8 (pack)
 import Control.Arrow ((***))
-import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
 import Data.Text (Text, unpack)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
+import Data.ByteString (ByteString)
 
 oauthUrl :: Text -> AuthRoute
 oauthUrl name = PluginR name ["forward"]
@@ -50,11 +49,8 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
         tm <- getRouteToMaster
         let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
         tok <- liftIO $ getTemporaryCredential oauth'
-        redirectString RedirectTemporary (fromString $ authorizeUrl oauth' tok)
+        redirectText RedirectTemporary (fromString $ authorizeUrl oauth' tok)
     dispatch "GET" [] = do
-        render <- getUrlRender
-        tm <- getRouteToMaster
-        let callback = render $ tm url
         verifier <- runFormGet' $ stringInput "oauth_verifier"
         oaTok    <- runFormGet' $ stringInput "oauth_token"
         let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok)
@@ -89,4 +85,5 @@ authTwitter = authOAuth "twitter"
 twitterUrl :: AuthRoute
 twitterUrl = oauthUrl "twitter"
 
+bsToText :: ByteString -> Text
 bsToText = decodeUtf8With lenientDecode

Yesod/Helpers/Auth/OpenId.hs

@@ -16,9 +16,8 @@ import Yesod.Widget
 import Yesod.Request
 import Text.Hamlet (hamlet)
 import Text.Cassius (cassius)
-import Text.Blaze (string)
+import Text.Blaze (toHtml)
 import Control.Monad.Trans.Class (lift)
-import qualified Data.ByteString.Char8 as S8
 import Data.Text (Text)
 
 forwardUrl :: AuthRoute
@@ -64,10 +63,10 @@ authOpenId =
                 res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing []
                 attempt
                   (\err -> do
-                        setMessage $ string $ show err
+                        setMessage $ toHtml $ show err
                         redirect RedirectTemporary $ toMaster LoginR
                         )
-                  (redirectString RedirectTemporary)
+                  (redirectText RedirectTemporary)
                   res
             _ -> do
                 toMaster <- getRouteToMaster
@@ -88,7 +87,7 @@ completeHelper gets' = do
         res <- runAttemptT $ OpenId.authenticate gets'
         toMaster <- getRouteToMaster
         let onFailure err = do
-            setMessage $ string $ show err
+            setMessage $ toHtml $ show err
             redirect RedirectTemporary $ toMaster LoginR
         let onSuccess (OpenId.Identifier ident, _) =
                 setCreds True $ Creds "openid" ident []

Yesod/Helpers/Auth/Rpxnow.hs

@@ -14,7 +14,7 @@ import Yesod.Widget
 import Yesod.Request
 import Text.Hamlet (hamlet)
 import Control.Monad.IO.Class (liftIO)
-import Data.Text (Text, pack, unpack)
+import Data.Text (pack, unpack)
 import Control.Arrow ((***))
 
 authRpxnow :: YesodAuth m