initial commit

App/Error.hs

@@ -0,0 +1,19 @@
+module App.Error (
+    PageNotFound(..)
+) where
+
+import Network.FastCGI
+import Network.URI
+import Template
+
+import Request
+
+data PageNotFound = PageNotFound
+
+instance RequestHandler PageNotFound where
+    handle handler = do
+        uri <- requestURI
+        let path = uriPath uri
+        res <- render "error404" [ ("pagetitle", "Seite nicht gefunden")
+                                 , ("path", path)]
+        output res

App/Info.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module App.Info (
+    Info(..)
+) where
+
+import Request
+import Template
+import Network.FastCGI
+
+data Info = Info
+
+instance RequestHandler Info where
+    handle handler = do
+        result <- render "info" [("pagetitle", "Info")]
+        output result

App/Login.hs

@@ -0,0 +1,84 @@
+module App.Login (
+    Login(..)
+) where
+
+import Control.Monad.State (gets)
+
+import Request
+import Template
+import Network.FastCGI
+import AppMonad (numVisited, App)
+import Database
+import Shared
+
+data Login = Login
+           | Register
+
+instance RequestHandler Login where
+    handle Login = do
+        loginStatus <- isLoggedIn
+        if loginStatus then alreadyLoggedIn else login
+    handle Register = do
+        loginStatus <- isLoggedIn
+        if loginStatus then alreadyLoggedIn else register
+
+loginSucceeded :: App CGIResult
+loginSucceeded = do
+    mayFrom <- getInput "from"
+    case mayFrom of
+        Just from -> redirect from
+        Nothing -> 
+            render "logged_in" [ ("pagetitle", "Angemeldet")
+                                         , ("kind", "jetzt") ] >>= output
+
+loginFailed :: App CGIResult
+loginFailed = do
+    result <- render "login" [("pagetitle", "Anmelden"),
+                              ("errormsg", "Ungültige Anmeldedaten")]
+    output result
+
+alreadyLoggedIn :: App CGIResult
+alreadyLoggedIn = do
+    result <- render "logged_in" [ ("pagetitle", "Angemeldet")
+                                 , ("kind", "bereits") ]
+    output result
+
+login :: App CGIResult
+login = do
+    mayLogin <- sequence <$> sequence [getInput "username", getInput "password"]
+    case mayLogin of
+        Just [username, password] ->
+            validate username password <: loginSucceeded <-> loginFailed
+        Nothing -> do
+            result <- render "login" [ ("pagetitle", "Anmelden")
+                                     , ("errormsg", "") ]
+            output result
+
+register :: App CGIResult
+register = do
+    mayRegister <- sequence <$> sequence [ getInput "username"
+                                         , getInput "password"
+                                         , getInput "confirm_password" ]
+    case mayRegister of
+        Just [username, password, password_confirm]
+            | password /= password_confirm ->
+                registerFailed "Passwörter stimmen nicht überein!"
+            | otherwise -> isAvailable username <:
+                goRegister username password <->
+                registerFailed "Benutername wird schon verwendet!"
+        Nothing -> do
+            res <- render "register" [ ("pagetitle", "Registrierung")
+                                     , ("errormsg",  "") ]
+            output res
+
+goRegister :: Username -> Password -> App CGIResult
+goRegister username password = do
+    addUser username password
+    res <- render "registered" [("pagetitle", "Registrierung abgeschlossen")]
+    output res
+
+registerFailed :: String -> App CGIResult
+registerFailed reason = do
+    res <- render "register" [ ("pagetitle", "Registrierung")
+                             , ("errormsg", reason ) ]
+    output res

App/Logout.hs

@@ -0,0 +1,32 @@
+module App.Logout (
+    Logout(..)    
+) where
+
+import Network.FastCGI
+
+import Request
+import Database
+import AppMonad
+import Template
+
+data Logout = Logout
+
+instance RequestHandler Logout where
+    handle handler = do
+        loginStatus <- isLoggedIn
+        if loginStatus then confirmLogout else redirect "/login"
+
+confirmLogout :: App CGIResult
+confirmLogout = do
+    method <- requestMethod
+    case method of
+        "POST" -> logout
+        _ -> render "confirm_logout" [ ("pagetitle", "Abmelden") ] >>= output
+
+logout :: App CGIResult
+logout = do
+    deleteCookie $ newCookie "username" ""
+    deleteCookie $ newCookie "login_string" ""
+    res <- render "logged_out" [ ("pagetitle", "Abgemeldet")
+                               , ("kind", "jetzt")]
+    output res

App/Private.hs

@@ -0,0 +1,19 @@
+module App.Private (
+    Private(..)    
+) where
+
+import Control.Monad.State (gets)
+
+import Request
+import Template
+import Network.FastCGI
+import AppMonad (numVisited, App)
+import Database
+
+data Private = Private
+
+instance RequestHandler Private where
+    requireLogin _ = True
+    handle handler = do
+        res <- render "private" [ ("pagetitle", "Geheimes Zeug") ]
+        output res

App/Startpage.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module App.Startpage (
+    Startpage(..)
+) where
+
+import Text.XHtml
+import Control.Monad.State (gets)
+
+import Request
+import Template
+import Network.FastCGI
+import AppMonad (numVisited)
+
+data Startpage = Startpage
+
+instance RequestHandler Startpage where
+    handle handler = do
+        n <- gets numVisited
+        result <- render "startpage" [("pagetitle", "Startseite"),
+                                      ("visited", show n)]
+        output result