{-# LANGUAGE OverloadedStrings #-}
module Happstack.Authenticate.OpenId.Route where

import Control.Applicative   ((<$>))
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, readTVar)
import Control.Monad.Reader  (ReaderT, runReaderT)
import Control.Monad.Trans   (liftIO)
import Data.Acid             (AcidState, closeAcidState, makeAcidic)
import Data.Acid.Advanced    (query')
import Data.Acid.Local       (createCheckpointAndClose, openLocalStateFrom)
import Data.Text             (Text)
import Data.UserId           (UserId)
import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod, AuthenticateConfig, AuthenticateState, AuthenticateURL, CoreError(..), toJSONError, toJSONResponse)
import Happstack.Authenticate.OpenId.Core (GetOpenIdRealm(..), OpenIdError(..), OpenIdState, initialOpenIdState, realm, token)
import Happstack.Authenticate.OpenId.Controllers (openIdCtrl)
import Happstack.Authenticate.OpenId.URL (OpenIdURL(..), openIdAuthenticationMethod, nestOpenIdURL)
import Happstack.Authenticate.OpenId.Partials (routePartial)
import Happstack.Server      (Happstack, Response, ServerPartT, acceptLanguage, bestLanguage, lookTexts', mapServerPartT, ok, notFound, queryString, toResponse, seeOther)
import Happstack.Server.JMacro ()
import HSP                        (unXMLGenT)
import HSP.HTML4                  (html4StrictFrag)
import Language.Javascript.JMacro (JStat)
import Network.HTTP.Conduit        (newManager, tlsManagerSettings)
import System.FilePath       (combine)
import Text.Shakespeare.I18N (Lang)
import Web.Authenticate.OpenId     (Identifier, OpenIdResponse(..), authenticateClaimed, getForwardUrl)
import Web.Routes            (PathInfo(..), RouteT(..), mapRouteT, nestURL, parseSegments, showURL)

------------------------------------------------------------------------------
-- routeOpenId
------------------------------------------------------------------------------

routeOpenId :: (Happstack m) =>
               AcidState AuthenticateState
            -> TVar AuthenticateConfig
            -> AcidState OpenIdState
            -> [Text]
            -> RouteT AuthenticateURL (ReaderT [Lang] m) Response
routeOpenId :: AcidState AuthenticateState
-> TVar AuthenticateConfig
-> AcidState OpenIdState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
routeOpenId AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV AcidState OpenIdState
openIdState [Text]
pathSegments =
  case URLParser OpenIdURL -> [Text] -> Either String OpenIdURL
forall a. URLParser a -> [Text] -> Either String a
parseSegments URLParser OpenIdURL
forall url. PathInfo url => URLParser url
fromPathSegments [Text]
pathSegments of
    (Left String
_) -> Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response)
-> Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall a b. (a -> b) -> a -> b
$ CoreError -> Response
forall e.
RenderMessage HappstackAuthenticateI18N e =>
e -> Response
toJSONError CoreError
URLDecodeFailed
    (Right OpenIdURL
url) ->
      do case OpenIdURL
url of
           (Partial PartialURL
u) ->
             do XML
xml <- XMLGenT (RouteT AuthenticateURL (ReaderT [Text] m)) XML
-> RouteT AuthenticateURL (ReaderT [Text] m) XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (AcidState AuthenticateState
-> AcidState OpenIdState
-> PartialURL
-> XMLGenT (RouteT AuthenticateURL (ReaderT [Text] m)) XML
forall (m :: * -> *).
(Functor m, Monad m, Happstack m) =>
AcidState AuthenticateState
-> AcidState OpenIdState -> PartialURL -> Partial m XML
routePartial AcidState AuthenticateState
authenticateState AcidState OpenIdState
openIdState PartialURL
u)
                Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response)
-> Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall a b. (a -> b) -> a -> b
$ (Maybe XMLMetaData, XML) -> Response
forall a. ToMessage a => a -> Response
toResponse (Maybe XMLMetaData
html4StrictFrag, XML
xml)
           (BeginDance Text
providerURL) ->
             do Text
returnURL <- RouteT OpenIdURL (ReaderT [Text] m) Text
-> RouteT AuthenticateURL (ReaderT [Text] m) Text
forall (m :: * -> *) a.
RouteT OpenIdURL m a -> RouteT AuthenticateURL m a
nestOpenIdURL (RouteT OpenIdURL (ReaderT [Text] m) Text
 -> RouteT AuthenticateURL (ReaderT [Text] m) Text)
-> RouteT OpenIdURL (ReaderT [Text] m) Text
-> RouteT AuthenticateURL (ReaderT [Text] m) Text
forall a b. (a -> b) -> a -> b
$ URL (RouteT OpenIdURL (ReaderT [Text] m))
-> RouteT OpenIdURL (ReaderT [Text] m) Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL (RouteT OpenIdURL (ReaderT [Text] m))
OpenIdURL
ReturnTo
                Maybe Text
realm <- AcidState (EventState GetOpenIdRealm)
-> GetOpenIdRealm
-> RouteT
     AuthenticateURL (ReaderT [Text] m) (EventResult GetOpenIdRealm)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState GetOpenIdRealm)
AcidState OpenIdState
openIdState GetOpenIdRealm
GetOpenIdRealm
                Text
forwardURL <- IO Text -> RouteT AuthenticateURL (ReaderT [Text] m) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> RouteT AuthenticateURL (ReaderT [Text] m) Text)
-> IO Text -> RouteT AuthenticateURL (ReaderT [Text] m) Text
forall a b. (a -> b) -> a -> b
$ do Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
                                          Text -> Text -> Maybe Text -> [(Text, Text)] -> Manager -> IO Text
forall (m :: * -> *).
MonadIO m =>
Text -> Text -> Maybe Text -> [(Text, Text)] -> Manager -> m Text
getForwardUrl Text
providerURL Text
returnURL Maybe Text
realm [] Manager
manager -- [("Email", "http://schema.openid.net/contact/email")]
                Text
-> Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther Text
forwardURL (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())
           OpenIdURL
ReturnTo ->
             do AuthenticateConfig
authenticateConfig <- IO AuthenticateConfig
-> RouteT AuthenticateURL (ReaderT [Text] m) AuthenticateConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AuthenticateConfig
 -> RouteT AuthenticateURL (ReaderT [Text] m) AuthenticateConfig)
-> IO AuthenticateConfig
-> RouteT AuthenticateURL (ReaderT [Text] m) AuthenticateConfig
forall a b. (a -> b) -> a -> b
$ STM AuthenticateConfig -> IO AuthenticateConfig
forall a. STM a -> IO a
atomically (STM AuthenticateConfig -> IO AuthenticateConfig)
-> STM AuthenticateConfig -> IO AuthenticateConfig
forall a b. (a -> b) -> a -> b
$ TVar AuthenticateConfig -> STM AuthenticateConfig
forall a. TVar a -> STM a
readTVar TVar AuthenticateConfig
authenticateConfigTV
                AcidState AuthenticateState
-> AuthenticateConfig
-> AcidState OpenIdState
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (m :: * -> *).
(Alternative m, Happstack m) =>
AcidState AuthenticateState
-> AuthenticateConfig -> AcidState OpenIdState -> m Response
token AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig AcidState OpenIdState
openIdState
           OpenIdURL
Realm    -> AcidState AuthenticateState
-> AcidState OpenIdState
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState -> AcidState OpenIdState -> m Response
realm AcidState AuthenticateState
authenticateState AcidState OpenIdState
openIdState

------------------------------------------------------------------------------
-- initOpenId
------------------------------------------------------------------------------

initOpenId :: FilePath
           -> AcidState AuthenticateState
           -> TVar AuthenticateConfig
           -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)
initOpenId :: String
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initOpenId String
basePath AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV =
  do AcidState OpenIdState
openIdState <- String -> OpenIdState -> IO (AcidState OpenIdState)
forall st.
(IsAcidic st, SafeCopy st) =>
String -> st -> IO (AcidState st)
openLocalStateFrom (String -> String -> String
combine String
basePath String
"openId") OpenIdState
initialOpenIdState
     let shutdown :: Bool -> IO ()
shutdown = \Bool
normal ->
           if Bool
normal
           then AcidState OpenIdState -> IO ()
forall st. (IsAcidic st, Typeable st) => AcidState st -> IO ()
createCheckpointAndClose AcidState OpenIdState
openIdState
           else AcidState OpenIdState -> IO ()
forall st. AcidState st -> IO ()
closeAcidState AcidState OpenIdState
openIdState
         authenticationHandler :: [Text] -> RouteT AuthenticateURL n Response
authenticationHandler [Text]
pathSegments =
           do [Text]
langsOveride <- RouteT AuthenticateURL n [Text] -> RouteT AuthenticateURL n [Text]
forall (m :: * -> *) a. HasRqData m => m a -> m a
queryString (RouteT AuthenticateURL n [Text]
 -> RouteT AuthenticateURL n [Text])
-> RouteT AuthenticateURL n [Text]
-> RouteT AuthenticateURL n [Text]
forall a b. (a -> b) -> a -> b
$ String -> RouteT AuthenticateURL n [Text]
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m [Text]
lookTexts' String
"_LANG"
              [Text]
langs        <- [(Text, Maybe Double)] -> [Text]
bestLanguage ([(Text, Maybe Double)] -> [Text])
-> RouteT AuthenticateURL n [(Text, Maybe Double)]
-> RouteT AuthenticateURL n [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteT AuthenticateURL n [(Text, Maybe Double)]
forall (m :: * -> *). Happstack m => m [(Text, Maybe Double)]
acceptLanguage
              (ReaderT [Text] n Response -> n Response)
-> RouteT AuthenticateURL (ReaderT [Text] n) Response
-> RouteT AuthenticateURL n Response
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT ((ReaderT [Text] n Response -> [Text] -> n Response)
-> [Text] -> ReaderT [Text] n Response -> n Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT [Text] n Response -> [Text] -> n Response
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ([Text]
langsOveride [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
langs)) (RouteT AuthenticateURL (ReaderT [Text] n) Response
 -> RouteT AuthenticateURL n Response)
-> RouteT AuthenticateURL (ReaderT [Text] n) Response
-> RouteT AuthenticateURL n Response
forall a b. (a -> b) -> a -> b
$
               AcidState AuthenticateState
-> TVar AuthenticateConfig
-> AcidState OpenIdState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] n) Response
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState
-> TVar AuthenticateConfig
-> AcidState OpenIdState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
routeOpenId AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV AcidState OpenIdState
openIdState [Text]
pathSegments
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
 RouteT AuthenticateURL (ServerPartT IO) JStat)
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO ()
shutdown, (AuthenticationMethod
openIdAuthenticationMethod, AuthenticationHandler
forall (n :: * -> *).
Happstack n =>
[Text] -> RouteT AuthenticateURL n Response
authenticationHandler), AcidState AuthenticateState
-> AcidState OpenIdState
-> RouteT AuthenticateURL (ServerPartT IO) JStat
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState
-> AcidState OpenIdState -> RouteT AuthenticateURL m JStat
openIdCtrl AcidState AuthenticateState
authenticateState AcidState OpenIdState
openIdState)