Snap OpenId persistent state example

gistfile1.hs

{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}

module Main where
------------------------------------------------------------------------------
-- explicit imports
------------------------------------------------------------------------------

import           Prelude hiding ((.), id)
import           Control.Category ((.))
import           Control.Applicative
import           Control.Monad.Reader (asks, ask)
import           Control.Monad.State  (get, gets, put)
import           Data.ByteString (ByteString)
import           Data.ByteString.Char8 (pack)
import           Data.String (fromString)
import           Data.SafeCopy (base, deriveSafeCopy)
import qualified Data.Text as T
import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
import           Data.Typeable (Typeable)
import           Data.IxSet ( Indexable(..), IxSet(..), (@=), Proxy(..), getOne
                             , ixFun, ixSet )
import qualified Data.IxSet as IxSet
import qualified Data.Map as M
import           Snap.Util.FileServe (serveDirectory)
import           Snap (SnapletInit, Snaplet, Handler, 
                 addRoutes, nestSnaplet, serveSnaplet,
                 defaultConfig, makeSnaplet, 
                 snapletValue, writeText, 
                 makeLens, getL, modL, modify, method)
import           Snap.Core
import           Snap.Snaplet.AcidState (Update, Query, Acid,
                 HasAcid (getAcidStore), makeAcidic, update, query, acidInit)
import qualified Web.Authenticate.OpenId as OpenId
import           Network.HTTP.Conduit (withManager)
import           Control.Monad.IO.Class
import           Snap.Snaplet.Session.Backends.CookieSession
import           Snap.Snaplet.Session
import           Snap.Snaplet (withTop)

------------------------------------------------------------------------------
-- acid-state code
------------------------------------------------------------------------------
data OpenIdUser = OpenIdUser
  { openIdIdentifier:: ByteString
  , name :: ByteString
  } deriving (Show, Eq, Ord, Typeable) 

deriveSafeCopy 0 'base ''OpenIdUser

data ApplicationState = ApplicationState
    { allUsers  :: IxSet OpenIdUser
    } deriving (Show,Ord,Eq,Typeable)

initApplicationState = ApplicationState {
	allUsers = IxSet.empty}

deriveSafeCopy 0 'base ''ApplicationState

lookupOpenIdUser :: ByteString -> Query ApplicationState (Maybe OpenIdUser)
lookupOpenIdUser ui = do
	ApplicationState {..} <- ask
	return $ getOne $ allUsers @= ui

insertNewOpenIdUser :: ByteString -> Update ApplicationState OpenIdUser
insertNewOpenIdUser ident = do
	a@ApplicationState{..} <- get
	let newUser = OpenIdUser { openIdIdentifier = ident
							 , name = "" }
	put $ a { allUsers = IxSet.insert newUser allUsers }
	return newUser

instance Indexable OpenIdUser where
	empty = ixSet [ ixFun $ \u -> [openIdIdentifier u], ixFun $ \u -> [name u] ]

makeAcidic ''ApplicationState ['lookupOpenIdUser, 'insertNewOpenIdUser]


------------------------------------------------------------------------------
-- snap code
------------------------------------------------------------------------------

data App = App
    { _acid :: Snaplet (Acid ApplicationState)
	, _sess :: Snaplet SessionManager
    }

type AppHandler = Handler App App

makeLens ''App

instance HasAcid App ApplicationState where
    getAcidStore = getL (snapletValue . acid)

routes :: [(ByteString, Handler App App ())]
routes = [ ("", serveDirectory "resources/static")
		 , ("/userId", userIdSession)
		 , ("/authenticate", authenticate)
		 , ("/authenticate/landing", authenticateLanding)
         ]

app :: SnapletInit App App
app = makeSnaplet "app" "An snaplet example application." Nothing $ do
    a <- nestSnaplet "acid" acid $ acidInit initApplicationState
    s <- nestSnaplet "sess" sess $ initCookieSessionManager "site_key.txt" "sess" Nothing --| (Just 3600)
    addRoutes routes
    return $ App a s



authenticate :: Handler App App ()
authenticate = do
        modifyResponse (setContentType "text/html")
        method POST process <|> form
    where
        form = do
            writeBS "Display form...<form method='POST'><input name='openid'></form>"
        process = do
			inp <- getParam "openid"
			case inp of
				Just x -> login x
				Nothing -> writeBS ("error")
			writeBS (fromString $ show inp)
login x = do
	url <- liftIO $ withManager $ OpenId.getForwardUrl (decodeUtf8 x) "http://localhost:8000/authenticate/landing" Nothing []
	redirect (encodeUtf8 url)

userIdSession :: Handler App App ()
userIdSession = do
	modifyResponse (setContentType "text/html")
	withTop sess $ do
		mui <- getFromSession "__user_id"
		writeBS (fromString $ show mui)

--| (UserObj, if it was created)
loginOrCreate :: ByteString -> Handler App App (OpenIdUser, Bool)
loginOrCreate ui = do
	possibleUser <- query $ LookupOpenIdUser ui :: Handler App App (Maybe OpenIdUser)
	case possibleUser of
			Just user -> return $ (user, False)
			Nothing   -> do
					user <- update $ InsertNewOpenIdUser ui
					return $ (user, True)

checkin :: ByteString -> Handler App App (OpenIdUser, Bool)
checkin ui = do
	(user, created) <- loginOrCreate ui
	withSession sess $ withTop sess $ setInSession "__user_id" (fromString $ show $ openIdIdentifier user)
	return (user, created)

convertParams :: Params -> [(T.Text, T.Text)]
convertParams params = [(decodeUtf8 k, decodeUtf8 (head v))| (k, v) <- (M.toList params)]

authenticateLanding :: Handler App App ()
authenticateLanding = do
	req <- getRequest
	oir <- liftIO $ withManager $ OpenId.authenticateClaimed (convertParams (rqParams req)) :: Handler App App (OpenId.OpenIdResponse)
	case OpenId.oirClaimed oir of
			Just ident -> do
					(user, created) <- checkin (encodeUtf8 $ OpenId.identifier $ ident)
					case created of
						False -> do
							writeBS ("Welcome Back")
						True  -> do
							writeBS ("Hello New User")
			Nothing    -> writeBS ("Unable to Login")

main = serveSnaplet defaultConfig app