{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, QuasiQuotes, TemplateHaskell, TypeOperators, TypeSynonymInstances, OverloadedStrings #-}
module Happstack.Authenticate.OpenId.Partials where

import Control.Category                     ((.), id)
import Control.Monad.Reader                 (ReaderT, ask, runReaderT)
import Control.Monad.Trans                  (MonadIO(..), lift)
import Data.Acid                            (AcidState)
import Data.Acid.Advanced                   (query')
import Data.Data                            (Data, Typeable)
import Data.Monoid                          ((<>))
import Data.Maybe                           (fromMaybe)
import Data.Text                            (Text)
import Data.UserId                          (UserId)
import qualified Data.Text                  as Text
import qualified Data.Text.Lazy             as LT
import HSP
import Happstack.Server.HSP.HTML            ()
import Language.Haskell.HSX.QQ              (hsx)
import Language.Javascript.JMacro
import Happstack.Authenticate.Core          (AuthenticateState, AuthenticateURL, User(..), HappstackAuthenticateI18N(..), getToken)
import Happstack.Authenticate.OpenId.Core   (OpenIdState(..), GetOpenIdRealm(..))
import Happstack.Authenticate.OpenId.URL    (OpenIdURL(..), nestOpenIdURL)
import Happstack.Authenticate.OpenId.PartialsURL  (PartialURL(..))
import Happstack.Server                     (Happstack, unauthorized)
import Happstack.Server.XMLGenT             ()
import HSP.JMacro                           ()
import Prelude                              hiding ((.), id)
import Text.Shakespeare.I18N                (Lang, mkMessageFor, renderMessage)
import Web.Authenticate.OpenId.Providers    (yahoo)
import Web.Routes
import Web.Routes.XMLGenT                   ()
import Web.Routes.TH                        (derivePathInfo)

type Partial' m = (RouteT AuthenticateURL (ReaderT [Lang] m))
type Partial  m = XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m))

data PartialMsgs
  = UsingYahooMsg
  | SetRealmMsg
  | OpenIdRealmMsg

mkMessageFor "HappstackAuthenticateI18N" "PartialMsgs" "messages/openid/partials" "en"

instance (Functor m, Monad m) => EmbedAsChild (Partial' m) PartialMsgs where
  asChild :: PartialMsgs -> GenChildList (Partial' m)
asChild PartialMsgs
msg =
    do [Lang]
lang <- XMLGenT (Partial' m) [Lang]
forall r (m :: * -> *). MonadReader r m => m r
ask
       Lang -> GenChildList (Partial' m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (Lang -> GenChildList (Partial' m))
-> Lang -> GenChildList (Partial' m)
forall a b. (a -> b) -> a -> b
$ HappstackAuthenticateI18N -> [Lang] -> PartialMsgs -> Lang
forall master message.
RenderMessage master message =>
master -> [Lang] -> message -> Lang
renderMessage HappstackAuthenticateI18N
HappstackAuthenticateI18N [Lang]
lang PartialMsgs
msg

instance (Functor m, Monad m) => EmbedAsAttr (Partial' m) (Attr LT.Text PartialMsgs) where
  asAttr :: Attr Text PartialMsgs -> GenAttributeList (Partial' m)
asAttr (Text
k := PartialMsgs
v) =
    do [Lang]
lang <- XMLGenT (Partial' m) [Lang]
forall r (m :: * -> *). MonadReader r m => m r
ask
       Attr Text Lang -> GenAttributeList (Partial' m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Text
k Text -> Lang -> Attr Text Lang
forall n a. n -> a -> Attr n a
:= HappstackAuthenticateI18N -> [Lang] -> PartialMsgs -> Lang
forall master message.
RenderMessage master message =>
master -> [Lang] -> message -> Lang
renderMessage HappstackAuthenticateI18N
HappstackAuthenticateI18N [Lang]
lang PartialMsgs
v)

routePartial
  :: (Functor m, Monad m, Happstack m) =>
     AcidState AuthenticateState
  -> AcidState OpenIdState
  -> PartialURL
  -> Partial m XML
routePartial :: AcidState AuthenticateState
-> AcidState OpenIdState -> PartialURL -> Partial m XML
routePartial AcidState AuthenticateState
authenticateState AcidState OpenIdState
openIdState PartialURL
url =
  case PartialURL
url of
    PartialURL
UsingYahoo     -> Partial m XML
forall (m :: * -> *). (Functor m, Monad m) => Partial m XML
usingYahoo
    PartialURL
RealmForm      -> AcidState OpenIdState -> Partial m XML
forall (m :: * -> *).
(Functor m, MonadIO m) =>
AcidState OpenIdState -> Partial m XML
realmForm AcidState OpenIdState
openIdState

usingYahoo :: (Functor m, Monad m) =>
              Partial m XML
usingYahoo :: Partial m XML
usingYahoo =
  do Lang
danceURL <- RouteT AuthenticateURL (ReaderT [Lang] m) Lang
-> XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) Lang
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RouteT AuthenticateURL (ReaderT [Lang] m) Lang
 -> XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) Lang)
-> RouteT AuthenticateURL (ReaderT [Lang] m) Lang
-> XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) Lang
forall a b. (a -> b) -> a -> b
$ RouteT OpenIdURL (ReaderT [Lang] m) Lang
-> RouteT AuthenticateURL (ReaderT [Lang] m) Lang
forall (m :: * -> *) a.
RouteT OpenIdURL m a -> RouteT AuthenticateURL m a
nestOpenIdURL  (RouteT OpenIdURL (ReaderT [Lang] m) Lang
 -> RouteT AuthenticateURL (ReaderT [Lang] m) Lang)
-> RouteT OpenIdURL (ReaderT [Lang] m) Lang
-> RouteT AuthenticateURL (ReaderT [Lang] m) Lang
forall a b. (a -> b) -> a -> b
$ URL (RouteT OpenIdURL (ReaderT [Lang] m))
-> RouteT OpenIdURL (ReaderT [Lang] m) Lang
forall (m :: * -> *). MonadRoute m => URL m -> m Lang
showURL (Lang -> OpenIdURL
BeginDance (String -> Lang
Text.pack String
yahoo))
     [hsx|
       <a ng-click=("openIdWindow('" <> danceURL <> "')")><img src="https://raw.githubusercontent.com/Happstack/authbuttons/master/png/yahoo_32.png" alt=UsingYahooMsg /></a>
     |]

realmForm
  :: (Functor m, MonadIO m) =>
     AcidState OpenIdState
  -> Partial m XML
realmForm :: AcidState OpenIdState -> Partial m XML
realmForm AcidState OpenIdState
openIdState =
  do Lang
url    <- RouteT AuthenticateURL (ReaderT [Lang] m) Lang
-> XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) Lang
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RouteT AuthenticateURL (ReaderT [Lang] m) Lang
 -> XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) Lang)
-> RouteT AuthenticateURL (ReaderT [Lang] m) Lang
-> XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) Lang
forall a b. (a -> b) -> a -> b
$ RouteT OpenIdURL (ReaderT [Lang] m) Lang
-> RouteT AuthenticateURL (ReaderT [Lang] m) Lang
forall (m :: * -> *) a.
RouteT OpenIdURL m a -> RouteT AuthenticateURL m a
nestOpenIdURL (RouteT OpenIdURL (ReaderT [Lang] m) Lang
 -> RouteT AuthenticateURL (ReaderT [Lang] m) Lang)
-> RouteT OpenIdURL (ReaderT [Lang] m) Lang
-> RouteT AuthenticateURL (ReaderT [Lang] m) Lang
forall a b. (a -> b) -> a -> b
$ URL (RouteT OpenIdURL (ReaderT [Lang] m))
-> RouteT OpenIdURL (ReaderT [Lang] m) Lang
forall (m :: * -> *). MonadRoute m => URL m -> m Lang
showURL URL (RouteT OpenIdURL (ReaderT [Lang] m))
OpenIdURL
Realm
     let setOpenIdRealmFn :: Lang
setOpenIdRealmFn = Lang
"setOpenIdRealm('" Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> Lang
url Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> Lang
"')"
     [hsx|
      <div ng-show="claims.authAdmin">
       <form ng-submit=setOpenIdRealmFn role="form">
        <div class="form-group">{{set_openid_realm_msg}}</div>
        <div class="form-group">
         <label for="openid-realm"><% OpenIdRealmMsg %></label>
         <input class="form-control" ng-model="openIdRealm.srOpenIdRealm" type="text" id="openid-realm" name="openIdRealm" />
        </div>
        <div class="form-group">
         <input class="form-control" type="submit" value=SetRealmMsg />
        </div>
       </form>
      </div>
     |]