{-# LANGUAGE FlexibleInstances #-}
module Happstack.Authenticate.Route where

import Control.Applicative ((<$>))
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, newTVar)
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 -> TVar AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)]
  -> IO (IO (), AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response, AcidState AuthenticateState, TVar AuthenticateConfig)
initAuthentication :: Maybe FilePath
-> AuthenticateConfig
-> [FilePath
    -> AcidState AuthenticateState
    -> TVar AuthenticateConfig
    -> IO
         (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
          RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> IO
     (IO (),
      AuthenticateURL
      -> RouteT AuthenticateURL (ServerPartT IO) Response,
      AcidState AuthenticateState, TVar AuthenticateConfig)
initAuthentication Maybe FilePath
mBasePath AuthenticateConfig
authenticateConfig [FilePath
 -> AcidState AuthenticateState
 -> TVar 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
     TVar AuthenticateConfig
authenticateConfigTV <- STM (TVar AuthenticateConfig) -> IO (TVar AuthenticateConfig)
forall a. STM a -> IO a
atomically (STM (TVar AuthenticateConfig) -> IO (TVar AuthenticateConfig))
-> STM (TVar AuthenticateConfig) -> IO (TVar AuthenticateConfig)
forall a b. (a -> b) -> a -> b
$ AuthenticateConfig -> STM (TVar AuthenticateConfig)
forall a. a -> STM (TVar a)
newTVar AuthenticateConfig
authenticateConfig
     -- 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
  -> TVar AuthenticateConfig
  -> IO
       (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
        RouteT AuthenticateURL (ServerPartT IO) JStat))
 -> IO
      (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
       RouteT AuthenticateURL (ServerPartT IO) JStat))
-> [FilePath
    -> AcidState AuthenticateState
    -> TVar 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
-> TVar AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initMethod -> FilePath
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initMethod FilePath
authenticatePath AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV) [FilePath
 -> AcidState AuthenticateState
 -> TVar 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, TVar AuthenticateConfig)
-> IO
     (IO (),
      AuthenticateURL
      -> RouteT AuthenticateURL (ServerPartT IO) Response,
      AcidState AuthenticateState, TVar AuthenticateConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ()
cleanup, AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
h, AcidState AuthenticateState
authenticateState, TVar AuthenticateConfig
authenticateConfigTV)

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)