{-# 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
------------------------------------------------------------------------------

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 [RouteT AuthenticateURL (ServerPartT IO) JStat]
controllers AuthenticationHandlers
authenticationHandlers AuthenticateURL
url =
  do case AuthenticateURL
url of
       (AuthenticationMethods (Just (AuthenticationMethod
authenticationMethod, [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 AuthenticationHandler
handler) -> AuthenticationHandler
handler [Text]
pathInfo
           Maybe AuthenticationHandler
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 {- authenticationMethod-} ) --FIXME
       AuthenticateURL
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)

------------------------------------------------------------------------------
-- initAuthenticate
------------------------------------------------------------------------------

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 Maybe FilePath
mBasePath AuthenticateConfig
authenticateConfig [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 FilePath
"state" Maybe FilePath
mBasePath) FilePath
"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 FilePath
"core") AuthenticateState
initialAuthenticateState
     -- FIXME: need to deal with one of the initMethods throwing an exception
     ([Bool -> IO ()]
cleanupPartial, [(AuthenticationMethod, AuthenticationHandler)]
handlers, [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 (\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 (\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` Int
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)