142 lines
5.0 KiB
Haskell
142 lines
5.0 KiB
Haskell
module Handler.Admin where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Jobs
|
|
|
|
import qualified Data.ByteString as BS
|
|
|
|
import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
|
|
import qualified Data.ByteString.Base64.URL as Base64
|
|
import Crypto.Saltine.Core.SecretBox (secretboxOpen)
|
|
import qualified Crypto.Saltine.Class as Saltine
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import Data.Char (isSpace)
|
|
|
|
import Control.Monad.Trans.Except
|
|
|
|
-- import Data.Time
|
|
-- import qualified Data.Text as T
|
|
-- import Data.Function ((&))
|
|
-- import Yesod.Form.Bootstrap3
|
|
|
|
import Web.PathPieces (showToPathPiece, readFromPathPiece)
|
|
|
|
import Database.Persist.Sql (fromSqlKey)
|
|
|
|
-- import Colonnade hiding (fromMaybe)
|
|
-- import Yesod.Colonnade
|
|
|
|
-- import qualified Data.UUID.Cryptographic as UUID
|
|
|
|
-- BEGIN - Buttons needed only here
|
|
data CreateButton = CreateMath | CreateInf -- Dummy for Example
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
|
|
instance PathPiece CreateButton where -- for displaying the button only, not really for paths
|
|
toPathPiece = showToPathPiece
|
|
fromPathPiece = readFromPathPiece
|
|
|
|
instance Button UniWorX CreateButton where
|
|
label CreateMath = [whamlet|Ma<i>thema</i>tik|]
|
|
label CreateInf = "Informatik"
|
|
|
|
cssClass CreateMath = BCInfo
|
|
cssClass CreateInf = BCPrimary
|
|
-- END Button needed here
|
|
|
|
emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
|
|
emailTestForm = (,)
|
|
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
|
|
<*> ( MailContext
|
|
<$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
|
|
<*> (toMailDateTimeFormat
|
|
<$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
|
|
)
|
|
)
|
|
<* submitButton
|
|
where
|
|
toMailDateTimeFormat dt d t = \case
|
|
SelFormatDateTime -> dt
|
|
SelFormatDate -> d
|
|
SelFormatTime -> t
|
|
|
|
|
|
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
|
|
getAdminTestR = postAdminTestR
|
|
postAdminTestR = do
|
|
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton)
|
|
case btnResult of
|
|
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
|
|
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
|
|
FormMissing -> return ()
|
|
_other -> addMessage Warning "KEIN Knopf erkannt"
|
|
|
|
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
|
|
case emailResult of
|
|
(FormSuccess (email, ls)) -> do
|
|
jId <- runDB $ do
|
|
jId <- queueJob $ JobSendTestEmail email ls
|
|
addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
|
|
return jId
|
|
writeJobCtl $ JobCtlPerform jId
|
|
FormMissing -> return ()
|
|
(FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
|
|
|
|
let emailWidget' = [whamlet|
|
|
<form method=post action=@{AdminTestR} enctype=#{emailEnctype}>
|
|
^{emailWidget}
|
|
|]
|
|
|
|
defaultLayout $ do
|
|
-- setTitle "Uni2work Admin Testpage"
|
|
$(widgetFile "adminTest")
|
|
|
|
|
|
getAdminUserR :: CryptoUUIDUser -> Handler Html
|
|
getAdminUserR uuid = do
|
|
uid <- decrypt uuid
|
|
User{..} <- runDB $ get404 uid
|
|
defaultLayout $
|
|
[whamlet|
|
|
<h1>TODO
|
|
<h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
|
|
|]
|
|
|
|
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
|
|
getAdminErrMsgR = postAdminErrMsgR
|
|
postAdminErrMsgR = do
|
|
errKey <- getsYesod appErrorMsgKey
|
|
|
|
((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
|
|
(unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
|
|
<* submitButton
|
|
|
|
plaintext <- formResultMaybe ctResult $ \(encodeUtf8 . Text.filter (not . isSpace) -> inputBS) ->
|
|
exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) $ do
|
|
ciphertext <- either (throwE . MsgErrMsgInvalidBase64) return $ Base64.decode inputBS
|
|
|
|
unless (BS.length ciphertext >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
|
|
throwE MsgErrMsgCiphertextTooShort
|
|
let (nonceBS, secretbox) = BS.splitAt Saltine.secretBoxNonce ciphertext
|
|
|
|
nonce <- maybe (throwE MsgErrMsgCouldNotDecodeNonce) return $ Saltine.decode nonceBS
|
|
|
|
plainBS <- maybe (throwE MsgErrMsgCouldNotOpenSecretbox) return $ secretboxOpen errKey nonce secretbox
|
|
|
|
either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS
|
|
|
|
defaultLayout $
|
|
[whamlet|
|
|
$maybe t <- plaintext
|
|
<pre style="white-space:pre-wrap; font-family:monospace">
|
|
#{t}
|
|
|
|
<form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
|
|
^{ctView}
|
|
|]
|