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

import Control.Applicative   ((<$>))
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
            -> AuthenticateConfig
            -> AcidState OpenIdState
            -> [Text]
            -> RouteT AuthenticateURL (ReaderT [Lang] m) Response
routeOpenId :: AcidState AuthenticateState
-> AuthenticateConfig
-> AcidState OpenIdState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
routeOpenId AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig 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) ->
      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 -> 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
           -> AuthenticateConfig
           -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)
initOpenId :: String
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initOpenId String
basePath AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig =
  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
-> AuthenticateConfig
-> AcidState OpenIdState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] n) Response
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState
-> AuthenticateConfig
-> AcidState OpenIdState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
routeOpenId AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig 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)