{-# LANGUAGE FlexibleInstances #-}
module Happstack.Authenticate.Route where
import Control.Applicative ((<$>))
import Control.Monad.Trans (MonadIO(liftIO))
import Data.Acid (AcidState)
import Data.Acid.Local (openLocalStateFrom, createCheckpointAndClose)
import qualified Data.Map as Map (fromList, lookup)
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Monoid (mconcat)
import Data.Traversable (sequence)
import Data.Unique (hashUnique, newUnique)
import Data.UserId (UserId)
import HSP.JMacro (IntegerSupply(..))
import Happstack.Authenticate.Controller (authenticateCtrl)
import Happstack.Authenticate.Core (AuthenticateConfig, AuthenticateState, AuthenticateURL(..), AuthenticationHandler, AuthenticationHandlers, AuthenticationMethod, CoreError(HandlerNotFound), initialAuthenticateState, toJSONError)
import Happstack.Server (notFound, ok, Response, ServerPartT, ToMessage(toResponse))
import Happstack.Server.JMacro ()
import Language.Javascript.JMacro (JStat)
import Prelude (($), (.), Bool(True), FilePath, fromIntegral, Functor(..), Integral(mod), IO, map, mapM, Monad(return), sequence_, unzip3)
import Prelude hiding (sequence)
import System.FilePath (combine)
import Web.Routes (RouteT)
route :: [RouteT AuthenticateURL (ServerPartT IO) JStat]
-> AuthenticationHandlers
-> AuthenticateURL
-> RouteT AuthenticateURL (ServerPartT IO) Response
route :: [RouteT AuthenticateURL (ServerPartT IO) JStat]
-> AuthenticationHandlers
-> AuthenticateURL
-> RouteT AuthenticateURL (ServerPartT IO) Response
route controllers :: [RouteT AuthenticateURL (ServerPartT IO) JStat]
controllers authenticationHandlers :: AuthenticationHandlers
authenticationHandlers url :: AuthenticateURL
url =
do case AuthenticateURL
url of
(AuthenticationMethods (Just (authenticationMethod :: AuthenticationMethod
authenticationMethod, pathInfo :: [Text]
pathInfo))) ->
case AuthenticationMethod
-> AuthenticationHandlers -> Maybe AuthenticationHandler
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AuthenticationMethod
authenticationMethod AuthenticationHandlers
authenticationHandlers of
(Just handler :: AuthenticationHandler
handler) -> AuthenticationHandler
handler [Text]
pathInfo
Nothing -> Response -> RouteT AuthenticateURL (ServerPartT IO) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> RouteT AuthenticateURL (ServerPartT IO) Response)
-> Response -> RouteT AuthenticateURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ CoreError -> Response
forall e.
RenderMessage HappstackAuthenticateI18N e =>
e -> Response
toJSONError (CoreError
HandlerNotFound )
Controllers ->
do [JStat]
js <- [RouteT AuthenticateURL (ServerPartT IO) JStat]
-> RouteT AuthenticateURL (ServerPartT IO) [JStat]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (RouteT AuthenticateURL (ServerPartT IO) JStat
forall (m :: * -> *). Monad m => RouteT AuthenticateURL m JStat
authenticateCtrlRouteT AuthenticateURL (ServerPartT IO) JStat
-> [RouteT AuthenticateURL (ServerPartT IO) JStat]
-> [RouteT AuthenticateURL (ServerPartT IO) JStat]
forall a. a -> [a] -> [a]
:[RouteT AuthenticateURL (ServerPartT IO) JStat]
controllers)
Response -> RouteT AuthenticateURL (ServerPartT IO) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> RouteT AuthenticateURL (ServerPartT IO) Response)
-> Response -> RouteT AuthenticateURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ JStat -> Response
forall a. ToMessage a => a -> Response
toResponse ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
js)
initAuthentication
:: Maybe FilePath
-> AuthenticateConfig
-> [FilePath -> AcidState AuthenticateState -> AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> IO (IO (), AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response, AcidState AuthenticateState)
initAuthentication :: Maybe FilePath
-> AuthenticateConfig
-> [FilePath
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> IO
(IO (),
AuthenticateURL
-> RouteT AuthenticateURL (ServerPartT IO) Response,
AcidState AuthenticateState)
initAuthentication mBasePath :: Maybe FilePath
mBasePath authenticateConfig :: AuthenticateConfig
authenticateConfig initMethods :: [FilePath
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)]
initMethods =
do let authenticatePath :: FilePath
authenticatePath = FilePath -> FilePath -> FilePath
combine (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "state" Maybe FilePath
mBasePath) "authenticate"
AcidState AuthenticateState
authenticateState <- FilePath -> AuthenticateState -> IO (AcidState AuthenticateState)
forall st.
(IsAcidic st, SafeCopy st) =>
FilePath -> st -> IO (AcidState st)
openLocalStateFrom (FilePath -> FilePath -> FilePath
combine FilePath
authenticatePath "core") AuthenticateState
initialAuthenticateState
(cleanupPartial :: [Bool -> IO ()]
cleanupPartial, handlers :: [(AuthenticationMethod, AuthenticationHandler)]
handlers, javascript :: [RouteT AuthenticateURL (ServerPartT IO) JStat]
javascript) <- [(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> ([Bool -> IO ()],
[(AuthenticationMethod, AuthenticationHandler)],
[RouteT AuthenticateURL (ServerPartT IO) JStat])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> ([Bool -> IO ()],
[(AuthenticationMethod, AuthenticationHandler)],
[RouteT AuthenticateURL (ServerPartT IO) JStat]))
-> IO
[(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> IO
([Bool -> IO ()], [(AuthenticationMethod, AuthenticationHandler)],
[RouteT AuthenticateURL (ServerPartT IO) JStat])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FilePath
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat))
-> IO
(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat))
-> [FilePath
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> IO
[(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\initMethod :: FilePath
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)
initMethod -> FilePath
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)
initMethod FilePath
authenticatePath AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig) [FilePath
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
(Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
RouteT AuthenticateURL (ServerPartT IO) JStat)]
initMethods
let cleanup :: IO ()
cleanup = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ AcidState AuthenticateState -> IO ()
forall st. (IsAcidic st, Typeable st) => AcidState st -> IO ()
createCheckpointAndClose AcidState AuthenticateState
authenticateState IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: (((Bool -> IO ()) -> IO ()) -> [Bool -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: Bool -> IO ()
c -> Bool -> IO ()
c Bool
True) [Bool -> IO ()]
cleanupPartial)
h :: AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
h = [RouteT AuthenticateURL (ServerPartT IO) JStat]
-> AuthenticationHandlers
-> AuthenticateURL
-> RouteT AuthenticateURL (ServerPartT IO) Response
route [RouteT AuthenticateURL (ServerPartT IO) JStat]
javascript ([(AuthenticationMethod, AuthenticationHandler)]
-> AuthenticationHandlers
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AuthenticationMethod, AuthenticationHandler)]
handlers)
(IO (),
AuthenticateURL
-> RouteT AuthenticateURL (ServerPartT IO) Response,
AcidState AuthenticateState)
-> IO
(IO (),
AuthenticateURL
-> RouteT AuthenticateURL (ServerPartT IO) Response,
AcidState AuthenticateState)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ()
cleanup, AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
h, AcidState AuthenticateState
authenticateState)
instance (Functor m, MonadIO m) => IntegerSupply (RouteT AuthenticateURL m) where
nextInteger :: RouteT AuthenticateURL m Integer
nextInteger =
(Unique -> Integer)
-> RouteT AuthenticateURL m Unique
-> RouteT AuthenticateURL m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (Unique -> Int) -> Unique -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 1024) (Int -> Int) -> (Unique -> Int) -> Unique -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique) (IO Unique -> RouteT AuthenticateURL m Unique
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
newUnique)