packages feed

Hawk (empty) → 0.0.2

raw patch · 63 files changed

+5225/−0 lines, 63 filesdep +HDBCdep +HDBC-sqlite3dep +HTTPsetup-changed

Dependencies added: HDBC, HDBC-sqlite3, HTTP, MonadCatchIO-mtl, SHA, base, bytestring, bytestring-trie, cgi, containers, convertible, data-default, dataenc, directory, filepath, hack, hslogger, hslogger-template, hxt, json-b, mtl, network, regex-posix, template-haskell, time, utf8-string

Files

+ Hawk.cabal view
@@ -0,0 +1,108 @@+Name:          Hawk+Version:       0.0.2+Description:   A library and framework to create Web Applications with Haskell+Synopsis:      Haskell Web Application Kit+License:       BSD3+License-file:  LICENCE+Author:        Björn Peemöller, Stefan Roggensack, Alexander Treptow+Maintainer:    Björn Peemöller <fh-wedel@gmx.de>, Stefan Roggensack, Alexander Treptow <alextreptow@gmx.de>+Build-Type:    Simple+Category:      Web+Cabal-Version: >=1.6++library+  ghc-options:       -Wall -fregs-graph+  hs-source-dirs:   src+  Build-Depends:     base == 4.*,+    HDBC >= 2.1.0 && <3,+    template-haskell >= 2.3.0.1 && <3,+    hslogger >= 1.0.7 && < 2,+    hslogger-template >= 1.0.0 && < 2,+    mtl >= 1.1.0.2 && < 2,+    containers >= 0.2.0.1 && < 1,+    filepath >= 1.1.0.2 && < 2,+    directory >= 1.0.0.3 && < 2,+    hack >= 2009.5.19 && < 3000,+    data-default >= 0.2 && < 1,+    time >= 1.1.3 && < 1.2,+    hxt >= 8.3.2 && < 9,+    bytestring >= 0.9.1.4 && < 1,+    utf8-string >= 0.3.4 && < 1,+    HTTP >= 4000.0.7 && < 5000,+    cgi >= 3001.1.7.1 && < 4000,+    SHA >= 1.4.0 && < 2,+    dataenc >= 0.13.0.0 && < 1,+    HDBC-sqlite3 >= 2.1.0.0 && < 3,+    network >= 2.2.1.3 && < 3,+    MonadCatchIO-mtl >= 0.2.0.0 && < 0.3,+    convertible >= 1.0.7 && < 1.1,+    regex-posix >= 0.94 && < 0.100,+    json-b >= 0.0.4 && < 0.1,+    bytestring-trie >= 0.1.4 && < 0.2+  Exposed-Modules:+    Control.Monad.Either+    Data.Stringable+    Data.EitherMapTree+    Hawk.Controller+    Hawk.Controller.Authenticate+    Hawk.Controller.Auth.ResultType+    Hawk.Controller.Auth.EmptyAuth+    Hawk.Controller.Auth.DbAuth+    Hawk.Controller.Auth.HttpAuth+    Hawk.Controller.Cookies+    Hawk.Controller.CustomResponses+    Hawk.Controller.Initializer+    Hawk.Controller.Mime+    Hawk.Controller.Request+    Hawk.Controller.Responses+    Hawk.Controller.Routes+    Hawk.Controller.Server+    Hawk.Controller.Session+    Hawk.Controller.Session.NoSession+    Hawk.Controller.Session.CookieSession+    Hawk.Controller.Session.DatabaseSession+--    Hawk.Controller.Session.UrlSession+    Hawk.Controller.StateAccess+    Hawk.Controller.Static+    Hawk.Controller.Types+    Hawk.Controller.Util.Read+    Hawk.Controller.Util.Monad+    Hawk.Controller.Util.Text+    Hawk.Controller.Util.Uri+    Hawk.Controller.Util.List+    Hawk.View+    Hawk.View.EmptyView+    Hawk.View.JsonView+    Hawk.View.TextView+    Hawk.View.Template.HtmlHelper+    Hawk.View.Template.Helper.TagHelper+    Hawk.View.Template.Helper.FormHelper+    Hawk.View.Template.Helper.DateHelper+    Hawk.View.Template.ToXhtml+    Hawk.View.Template.Interpreter+    Hawk.View.Template.DataType+    Hawk.View.TemplateView+    Hawk.Model+    Hawk.Model.MonadDB+    Hawk.Model.WithPrimaryKey+    Hawk.Model.Criteria.Order+    Hawk.Model.Criteria.Projection+    Hawk.Model.Criteria.Criteria+    Hawk.Model.Criteria.Restriction+    Hawk.Model.Criteria.Types+    Hawk.Model.Exception+    Hawk.Model.Validator+    Hawk.Model.Persistent+    Hawk.Model.Model+    Hawk.Model.Updater+    Hawk.Model.Criteria+    Hawk.Model.Util+    Hawk.Model.CriteriaSelect+    Hawk.Model.WithForeignKey+    Hawk.Model.Types+    Hawk.Model.Association+-- Non Hawk Modules++--  Other-Modules:++-- Tests:     Hawk.Model.Criteria.Test
+ LICENCE view
@@ -0,0 +1,10 @@+Copyright (c) 2010, Björn Peemöller, Stefan Roggensack, Alexander Treptow+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * Neither the name of the FH Wedel nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ src/Control/Monad/Either.hs view
@@ -0,0 +1,125 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  Control.Monad.Either
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  NONE
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+
+   Monad transformer for Either, inspired by Control.Monad.ErrorT but without
+   the Error restriction of the Left value.
+-}
+-- --------------------------------------------------------------------------
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
+module Control.Monad.Either
+	( EitherT (..)
+  , returnLeft
+  , mapEitherT
+  , module Control.Monad
+  , module Control.Monad.Fix
+  , module Control.Monad.Trans
+	) where
+
+import Control.Monad
+import Control.Monad.CatchIO
+import Control.Monad.Fix
+import Control.Monad.RWS.Class
+import Control.Monad.Trans
+import Prelude hiding (catch)
+
+-- --------------------------------------------------------------------------
+-- instances for Either
+-- --------------------------------------------------------------------------
+{-
+instance Monad (Either e) where
+  return = Right
+  Right m >>= k = k m
+  Left e  >>= _ = Left e
+
+instance Applicative (Either e) where
+	pure = Right
+	a <*> b = do x <- a; y <- b; return (x y)
+
+instance MonadFix (Either e) where
+	mfix f = let
+		a = f $ case a of
+			Right r -> r
+			_ -> error "empty mfix argument"
+		in a
+-}
+-- --------------------------------------------------------------------------
+-- Definitions for EitherT
+-- --------------------------------------------------------------------------
+
+newtype EitherT a m b = EitherT { runEitherT :: m (Either a b) }
+
+returnLeft :: Monad m => a -> EitherT a m b
+returnLeft = EitherT . return . Left
+
+mapEitherT :: (m (Either a b) -> n (Either a' b'))
+           -> EitherT a m b
+           -> EitherT a' n b'
+mapEitherT f = EitherT . f . runEitherT
+
+-- --------------------------------------------------------------------------
+-- instances for EitherT
+-- --------------------------------------------------------------------------
+instance Functor f => Functor (EitherT a f) where
+	fmap f = EitherT . fmap (fmap f) . runEitherT
+
+instance Monad m => Monad (EitherT a m) where
+  return  = EitherT . return . Right
+  m >>= k = EitherT $ do
+    a <- runEitherT m
+    case a of
+    	Left  l -> return (Left l)
+    	Right r -> runEitherT (k r)
+
+instance MonadFix m => MonadFix (EitherT a m) where
+	mfix f = EitherT $ mfix $ \a -> runEitherT $ f $ case a of
+        	Right r -> r
+        	_       -> error "empty mfix argument"
+
+-- --------------------------------------------------------------------------
+-- instances for mtl transformers
+-- --------------------------------------------------------------------------
+instance MonadTrans (EitherT e) where
+  lift = EitherT . liftM Right
+
+instance MonadIO m => MonadIO (EitherT e m) where
+  liftIO = lift . liftIO
+
+instance MonadRWS r w s m => MonadRWS r w s (EitherT e m)
+
+instance MonadReader r m => MonadReader r (EitherT e m) where
+  ask     = lift ask
+  local f = EitherT . local f . runEitherT
+
+instance MonadState s m => MonadState s (EitherT e m) where
+  get = lift get
+  put = lift . put
+
+instance MonadWriter w m => MonadWriter w (EitherT e m) where
+  tell     = lift . tell
+  listen m = EitherT $ do
+    (a, w) <- listen $ runEitherT m
+    case a of
+      Left  l -> return $ Left l
+      Right r -> return $ Right (r, w)
+  pass m   = EitherT $ pass $ do
+    a <- runEitherT m
+    case a of
+      Left  l      -> return (Left  l, id)
+      Right (r, f) -> return (Right r, f)
+
+-- --------------------------------------------------------------------------
+-- instance for MonadCatchIO
+-- --------------------------------------------------------------------------
+instance MonadCatchIO m => MonadCatchIO (EitherT e m) where
+  m `catch` f = mapEitherT (`catch` (runEitherT . f)) m
+  block       = mapEitherT block
+  unblock     = mapEitherT unblock
+
+ src/Data/EitherMapTree.hs view
@@ -0,0 +1,14 @@+module Data.EitherMapTree where++import qualified Data.Map as M++data EitherMapTree a b = Node {+    subNodes :: M.Map a (Either [EitherMapTree a b] b)+    }+    deriving (Show)++lookup :: (Ord a) => a -> EitherMapTree a b -> Maybe (Either [EitherMapTree a b] b)+lookup k (Node sn) = M.lookup k sn++fromList :: Ord a => [(a, Either [EitherMapTree a b] b)] -> EitherMapTree a b+fromList = Node . M.fromList
+ src/Data/Stringable.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeSynonymInstances #-}+module Data.Stringable where++class Stringable a where+    toString :: a -> String++instance Stringable String where+    toString = id++instance Show a => Stringable a where+    toString = show
+ src/Hawk/Controller.hs view
@@ -0,0 +1,35 @@+module Hawk.Controller+  ( module Hawk.Controller.Authenticate     -- ^ Authentication handling+  , module Hawk.Controller.Cookies          -- ^ Cookie handling+  , module Hawk.Controller.CustomResponses  -- ^ Custom response+  , module Hawk.Controller.Request          -- ^ Request handling+  , module Hawk.Controller.Routes           -- ^ Routing+  , module Hawk.Controller.Session          -- ^ Session handling+  , module Hawk.Controller.StateAccess      -- ^ Session and Flash message handling+  , module Hawk.Controller.Util.Monad       -- ^+  , module Hawk.Controller.Types            -- ^ Types+  ) where++import Hawk.Controller.Authenticate+import Hawk.Controller.Cookies+import Hawk.Controller.CustomResponses+import Hawk.Controller.Request+import Hawk.Controller.Routes+  ( addUrlParams+  , urlFor+  , actionUrl+  , combine+  )+import Hawk.Controller.Session+import Hawk.Controller.StateAccess+import Hawk.Controller.Util.Monad+  ( concatMapM+  , liftMaybe+  )+import Hawk.Controller.Types++++++
+ src/Hawk/Controller/Auth/DbAuth.hs view
@@ -0,0 +1,58 @@+module Hawk.Controller.Auth.DbAuth where++import Hawk.Controller.Types+import Hawk.Controller.Authenticate+import Hawk.Controller.Request ( getParam )++import Hawk.Model.Criteria+import Hawk.Model.CriteriaSelect++import Database.HDBC.SqlValue+import Control.Monad.Trans ()+import Control.Monad.Reader++-- authOpts are: [tableName, identityColumnName, credentialColumnName, cryptoFunctionName, username-formfield, password-formfield]++--(MonadDB m, MonadIO m, HasState m) => String -> String -> m AuthResult+dbAuth :: AuthType+dbAuth = do+    sess <- isAuthed+    case sess of+      False -> do+        (t, idCol, credCol, crypto, user, pass) <- getOpts+        u <- getParam user+        p <- getParam pass+        --select idcol and credcol from table where idcol == id+        rows <- querySelect+             $ setProjection [colP idCol, colP credCol]+             $ setTables [t]+             $ setCriteria (restrictionCriteria ((val u) .==. (col idCol)))+             $ newSelect+--        let rows = [[SqlString "admin"]]+        case rows of+          (x:[])   -> case lookupAuthDbRes (encrypt crypto p) x of -- compare for correct password+                        Nothing -> return AuthFailureInvalidCredential+                        Just _  -> setSessionAuth u >> return AuthSuccess+          (_:_:_) -> return AuthFailureAmbiguousId       -- id is not unique+          _        -> return AuthFailureIdNotFound        -- no identity found+      True -> return AuthSuccess++getOpts :: (MonadIO m, HasState m) => m (String, String, String, String, String, String)+getOpts = do+  conf <- asks configuration+  let o = authOpts conf +  case o of+    (t:i:c:cr:uf:pf:_) -> return (t, i, c, cr, uf, pf)+    _ -> return ("wrong-authOpts", "", "", "", "", "") -- this will occur in a db request error++lookupAuthDbRes :: String -> [SqlValue] -> Maybe String+lookupAuthDbRes _ [] = Nothing+lookupAuthDbRes s (x:xs)+  | s == (fromSql x) = Just s+  | otherwise        = lookupAuthDbRes s xs++encrypt :: String -> String -> String+encrypt "MD5"      s = s -- hash s to md5+encrypt "PASSWORD" s = s -- do the password encryption algorithm for the db+encrypt _          s = s+
+ src/Hawk/Controller/Auth/EmptyAuth.hs view
@@ -0,0 +1,6 @@+module Hawk.Controller.Auth.EmptyAuth where++import Hawk.Controller.Types++emptyAuth :: AuthType+emptyAuth = return $ AuthFailureUnknown "Empty authentication handler"
+ src/Hawk/Controller/Auth/HttpAuth.hs view
@@ -0,0 +1,49 @@+module Hawk.Controller.Auth.HttpAuth where++import Hawk.Controller.Types+import Hawk.Controller.Authenticate++import Hawk.Controller.Request+import Hawk.Controller.Util.Text++import Control.Monad.Trans()+import Control.Monad.Reader++import Codec.Binary.Base64 ( decode )+import qualified Codec.Binary.UTF8.String as UTF8 (decode)++-- only supports csv based basic authentication+-- this http authentication is only usable for a single userclass+-- maybe extend this by multiple domain specific configurations ?+-- (MonadDB m, MonadIO m, HasState m) => String -> String -> m AuthResult+httpAuth :: AuthType+httpAuth = do+  sess <- isAuthed+  (if sess then return AuthSuccess else+     (do a <- getRequestHeader "Authorization"+         case a of+             Nothing -> return AuthFailureIdNotFound+             Just v -> case decode (snd (splitWhere (== ' ') v)) of+                   Nothing -> return AuthFailureIdNotFound+                   Just v' -> uncurry httpAuth' $+                        splitWhere (== ':') (UTF8.decode v')))+  where +  httpAuth' u p = do+    path <- getOpts+    fc <- liftIO (readFile path)+    let t = splitAll (== ',') fc+        l = map (splitWhere (== ':')) t+    case (lookup u l) of+      Nothing -> return AuthFailureIdNotFound+      Just v -> if v == p+        then setSessionAuth u >> return AuthSuccess+        else return AuthFailureInvalidCredential++getOpts :: (MonadIO m, HasState m) => m String+getOpts = do+  conf <- asks configuration+  let o = authOpts conf +  case o of+    (p:_) -> return p+    _ -> return "wrong-authOpts" -- this will occur in a db request error+
+ src/Hawk/Controller/Auth/ResultType.hs view
@@ -0,0 +1,8 @@+module Hawk.Controller.Auth.ResultType (AuthResult (..)) where++data AuthResult = AuthSuccess+                | AuthFailureUnknown String -- can contain a sql exception string+                | AuthFailureIdNotFound+                | AuthFailureAmbiguousId+                | AuthFailureInvalidCredential+
+ src/Hawk/Controller/Authenticate.hs view
@@ -0,0 +1,58 @@+--{-# LANGUAGE FlexibleContexts, TypeFamilies #-}+-- session handling is required for authentification+module Hawk.Controller.Authenticate+where++--import Hawk.Controller.Types +import Hawk.Controller.StateAccess ( getSessionValue, setSessionValue, deleteSessionKey, setFlash )+import Hawk.Controller.CustomResponses ( redirectToAction )+import Hawk.Controller.Types -- ( AuthType (..) )++import Control.Monad.Reader++import Data.Maybe (isJust)++-- monaddb only needed for db auth support+auth :: AuthType --(MonadDB m, MonadIO m, HasState m) => m AuthResult+auth = asks configuration >>= authType++tryLogin :: AuthType+tryLogin = auth++getSessionAuth :: (HasState m) => m (Maybe String)+getSessionAuth = getSessionValue authKey++setSessionAuth :: (HasState m) => String -> m ()+setSessionAuth = setSessionValue authKey++delSessionAuth :: (HasState m) => m ()+delSessionAuth = deleteSessionKey authKey++logout :: (HasState m) => m ()+logout = delSessionAuth++isAuthedAs :: (HasState m) => m (Maybe String)+isAuthedAs = getSessionAuth++isAuthed :: (HasState m) => m Bool+isAuthed = isJust `liftM` getSessionAuth++authKey :: String+authKey = "user_auth"++-- argumente sind hier die aktion auf die redirected werden soll+authF :: String -> String -> StateController a -> StateController a+authF = authF' ""++authF' :: String -> String -> String -> StateController a -> StateController a+authF' e c a contr = do+  b <- isAuthed+  if b+    then contr+    else+      case e of +        "" -> redirectToAction c a+        _ -> do+          setFlash "error" e --"You are not logged in."+          redirectToAction c a+
+ src/Hawk/Controller/Cookies.hs view
@@ -0,0 +1,92 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+   
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+  
+   Functions for working with Cookies. This module uses the Cookie functions+   from Network.CGI.Cookies.+   May be updated to reflect RFC 2965 in the future.
+-}
+-- --------------------------------------------------------------------------+module Hawk.Controller.Cookies+  ( Cookie (..)+  , newCookie+  , getCookie+  , getCookieValue+  , setCookie+  , setCookieValue+  , deleteCookie+  , withCookies+  , setTestCookie+  , checkTestCookie+  ) where++import Hawk.Controller.Responses (addHeader)+import Hawk.Controller.Util.List (replaceOrAdd, lookupFirst)+import Hawk.Controller.Types++import Control.Monad (liftM)+import Control.Monad.State (gets, modify)+import Control.Monad.Reader (asks)+import Data.List (intercalate)+import Network.CGI.Cookie+  ( Cookie (..)+  , newCookie+  , showCookie+  , readCookies+  )+import qualified Network.CGI.Cookie as C (deleteCookie)+import Network.HTTP.Headers (HeaderName(..))++testCookie :: (String, String)+testCookie = ("foo", "42")++getRequestCookies :: HasState m => m [Cookie]+getRequestCookies = do+  cookieHeader <- asks $ lookup (show HdrCookie) . http . request+  case cookieHeader of+    Nothing  -> return []+    Just hdr -> return $ map (uncurry newCookie) $ readCookies hdr++getCookie :: HasState m => String -> m (Maybe Cookie)+getCookie name = do+  newCookies <- gets cookies+  oldCookies <- getRequestCookies+  return $ lookupFirst ((==name) . cookieName) (newCookies ++ oldCookies)++getCookieValue :: HasState m => String -> m (Maybe String)+getCookieValue = liftM (liftM cookieValue) . getCookie++setCookie :: HasState m => Cookie -> m ()+setCookie c = modify $ \s -> s { cookies = replaceOrAdd cmp c $ cookies s }+  where cmp c1 c2 = cookieName c1 == cookieName c2++setCookieValue :: HasState m => String -> String -> m ()+setCookieValue name value = do+  old <- getCookie name+  setCookie $ maybe (newCookie name value) (\c -> c { cookieValue = value }) old++deleteCookie :: HasState m => String -> m ()+deleteCookie name = setCookie $ C.deleteCookie $ newCookie name ""++withCookies :: HasState m => m Response -> m Response+withCookies contr = do+  res <- contr+  cs <- gets cookies+  case cs of+    [] -> return res+    cl -> return $ addHeader HdrSetCookie (intercalate ";" $ map showCookie cl) res++setTestCookie :: HasState m => m ()+setTestCookie = uncurry setCookieValue testCookie++checkTestCookie :: HasState m => m Bool+checkTestCookie = do+    t <- getCookieValue (fst testCookie) +    return $ maybe False ((==) $ snd testCookie) t
+ src/Hawk/Controller/CustomResponses.hs view
@@ -0,0 +1,22 @@+module Hawk.Controller.CustomResponses where++import Control.Monad.Either+import Hawk.Controller.Responses+import Hawk.Controller.Request (getParamsAsList)+import Hawk.Controller.Routes (actionUrl)+import Hawk.Controller.Types++customResponse :: Response -> StateController a+customResponse = returnLeft++redirectToUrl :: String -> StateController a+redirectToUrl = customResponse . redirectResponse++redirectTo :: String -> String -> [(String, String)] -> StateController a+redirectTo c a ps = actionUrl c a ps >>= redirectToUrl++redirectToAction :: String -> String -> StateController a+redirectToAction c a = redirectTo c a []++redirectWithParams :: String -> String -> StateController a+redirectWithParams c a = getParamsAsList >>= redirectTo c a
+ src/Hawk/Controller/Initializer.hs view
@@ -0,0 +1,69 @@+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   The initializer for loading the environment, connecting to the database+   and such stuff.+-}+-- --------------------------------------------------------------------------+{-# LANGUAGE Rank2Types #-}+module Hawk.Controller.Initializer+  ( AppEnvironment (..)+  , loadEnvironment+  , updateLogger+  , getApplication+--  , AppConfiguration+  ) where++import Hawk.Controller.Types+  ( BasicConfiguration+  , Options+  , AppConfiguration (..)+  )++import System.Log.Logger+  ( Priority+  , updateGlobalLogger+  , setLevel+--  , rootLoggerName+  )+  +import Control.Monad.Trans++import Database.HDBC (ConnWrapper)+import Hack (Application)++import Hawk.Controller.Server (requestHandler)++-- | 'AppEnvironment' you have to define to run your application properly+data AppEnvironment = AppEnvironment+  { connectToDB :: IO ConnWrapper       -- ^ DB connection to your DB, e.g. $ConnWrapper \`liftM\` connectSqlite3 \".\/db\/database.db\"$+                                        -- atm only Sqlite3 is supported+  , logLevels   :: [(String, Priority)] -- ^+  , envOptions  :: Options              -- ^+  }++loadEnvironment :: AppEnvironment -> IO (ConnWrapper, Options)+loadEnvironment appEnv = do+  updateLogger (logLevels appEnv)+  db <- connectToDB appEnv+  return (db, envOptions appEnv)++updateLogger :: [(String, Priority)] -> IO ()+updateLogger = mapM_ (\(name, level) -> updateGlobalLogger name (setLevel level))++-- | Call this function to encapsulate your application into Hawk-Framework+getApplication :: (forall a m. (AppConfiguration a, MonadIO m) => m a)  -- ^ 'AppConfiguration' Type you defined in your application, not known to Hawk+               -> AppEnvironment     -- ^ 'AppEnvironment' look above+               -> BasicConfiguration -- ^ Hawk configuration Type+               -> Application+getApplication app env conf x = do+  (conn, envOpts) <- loadEnvironment env+  requestHandler app conn conf envOpts x
+ src/Hawk/Controller/Mime.hs view
@@ -0,0 +1,199 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+   
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+  
+   Static map for MIME-Types
+-}
+-- --------------------------------------------------------------------------+module Hawk.Controller.Mime where++import qualified Data.Map as M+  ( Map+  , lookup+  , fromList+  )++import Data.Maybe (fromMaybe)++getMimeType :: String -> String+getMimeType = fromMaybe "text/plain" . lookupMimeType++lookupMimeType :: String -> Maybe String+lookupMimeType = flip M.lookup mimeTypes++mimeTypes :: M.Map String String+mimeTypes = M.fromList+   [  x     ".3gp"          "video/3gpp"+   ,  x     ".a"            "application/octet-stream"+   ,  x     ".ai"           "application/postscript"+   ,  x     ".aif"          "audio/x-aiff"+   ,  x     ".aiff"         "audio/x-aiff"+   ,  x     ".asc"          "application/pgp-signature"+   ,  x     ".asf"          "video/x-ms-asf"+   ,  x     ".asm"          "text/x-asm"+   ,  x     ".asx"          "video/x-ms-asf"+   ,  x     ".atom"         "application/atom+xml"+   ,  x     ".au"           "audio/basic"+   ,  x     ".avi"          "video/x-msvideo"+   ,  x     ".bat"          "application/x-msdownload"+   ,  x     ".bin"          "application/octet-stream"+   ,  x     ".bmp"          "image/bmp"+   ,  x     ".bz2"          "application/x-bzip2"+   ,  x     ".c"            "text/x-c"+   ,  x     ".cab"          "application/vnd.ms-cab-compressed"+   ,  x     ".cc"           "text/x-c"+   ,  x     ".chm"          "application/vnd.ms-htmlhelp"+   ,  x     ".class"        "application/octet-stream"+   ,  x     ".com"          "application/x-msdownload"+   ,  x     ".conf"         "text/plain"+   ,  x     ".cpp"          "text/x-c"+   ,  x     ".crt"          "application/x-x509-ca-cert"+   ,  x     ".css"          "text/css"+   ,  x     ".csv"          "text/csv"+   ,  x     ".cxx"          "text/x-c"+   ,  x     ".deb"          "application/x-debian-B.package"+   ,  x     ".der"          "application/x-x509-ca-cert"+   ,  x     ".diff"         "text/x-diff"+   ,  x     ".djv"          "image/vnd.djvu"+   ,  x     ".djvu"         "image/vnd.djvu"+   ,  x     ".dll"          "application/x-msdownload"+   ,  x     ".dmg"          "application/octet-stream"+   ,  x     ".doc"          "application/msword"+   ,  x     ".dot"          "application/msword"+   ,  x     ".dtd"          "application/xml-dtd"+   ,  x     ".dvi"          "application/x-dvi"+   ,  x     ".ear"          "application/java-archive"+   ,  x     ".eml"          "message/rfc822"+   ,  x     ".eps"          "application/postscript"+   ,  x     ".exe"          "application/x-msdownload"+   ,  x     ".f"            "text/x-fortran"+   ,  x     ".f77"          "text/x-fortran"+   ,  x     ".f90"          "text/x-fortran"+   ,  x     ".flv"          "video/x-flv"+   ,  x     ".for"          "text/x-fortran"+   ,  x     ".gem"          "application/octet-stream"+   ,  x     ".gemspec"      "text/x-script.ruby"+   ,  x     ".gif"          "image/gif"+   ,  x     ".gz"           "application/x-gzip"+   ,  x     ".h"            "text/x-c"+   ,  x     ".hh"           "text/x-c"+   ,  x     ".htm"          "text/html"+   ,  x     ".html"         "text/html"+   ,  x     ".ico"          "image/vnd.microsoft.icon"+   ,  x     ".ics"          "text/calendar"+   ,  x     ".ifb"          "text/calendar"+   ,  x     ".iso"          "application/octet-stream"+   ,  x     ".jar"          "application/java-archive"+   ,  x     ".java"         "text/x-java-source"+   ,  x     ".jnlp"         "application/x-java-jnlp-file"+   ,  x     ".jpeg"         "image/jpeg"+   ,  x     ".jpg"          "image/jpeg"+   ,  x     ".js"           "application/javascript"+   ,  x     ".json"         "application/json"+   ,  x     ".log"          "text/plain"+   ,  x     ".m3u"          "audio/x-mpegurl"+   ,  x     ".m4v"          "video/mp4"+   ,  x     ".man"          "text/troff"+   ,  x     ".mathml"       "application/mathml+xml"+   ,  x     ".mbox"         "application/mbox"+   ,  x     ".mdoc"         "text/troff"+   ,  x     ".me"           "text/troff"+   ,  x     ".mid"          "audio/midi"+   ,  x     ".midi"         "audio/midi"+   ,  x     ".mime"         "message/rfc822"+   ,  x     ".mml"          "application/mathml+xml"+   ,  x     ".mng"          "video/x-mng"+   ,  x     ".mov"          "video/quicktime"+   ,  x     ".mp3"          "audio/mpeg"+   ,  x     ".mp4"          "video/mp4"+   ,  x     ".mp4v"         "video/mp4"+   ,  x     ".mpeg"         "video/mpeg"+   ,  x     ".mpg"          "video/mpeg"+   ,  x     ".ms"           "text/troff"+   ,  x     ".msi"          "application/x-msdownload"+   ,  x     ".odp"          "application/vnd.oasis.opendocument.presentation"+   ,  x     ".ods"          "application/vnd.oasis.opendocument.spreadsheet"+   ,  x     ".odt"          "application/vnd.oasis.opendocument.text"+   ,  x     ".ogg"          "application/ogg"+   ,  x     ".p"            "text/x-pascal"+   ,  x     ".pas"          "text/x-pascal"+   ,  x     ".pbm"          "image/x-portable-bitmap"+   ,  x     ".pdf"          "application/pdf"+   ,  x     ".pem"          "application/x-x509-ca-cert"+   ,  x     ".pgm"          "image/x-portable-graymap"+   ,  x     ".pgp"          "application/pgp-encrypted"+   ,  x     ".pkg"          "application/octet-stream"+   ,  x     ".pl"           "text/x-script.perl"+   ,  x     ".pm"           "text/x-script.perl-module"+   ,  x     ".png"          "image/png"+   ,  x     ".pnm"          "image/x-portable-anymap"+   ,  x     ".ppm"          "image/x-portable-pixmap"+   ,  x     ".pps"          "application/vnd.ms-powerpoint"+   ,  x     ".ppt"          "application/vnd.ms-powerpoint"+   ,  x     ".ps"           "application/postscript"+   ,  x     ".psd"          "image/vnd.adobe.photoshop"+   ,  x     ".py"           "text/x-script.python"+   ,  x     ".qt"           "video/quicktime"+   ,  x     ".ra"           "audio/x-pn-realaudio"+   ,  x     ".rake"         "text/x-script.ruby"+   ,  x     ".ram"          "audio/x-pn-realaudio"+   ,  x     ".rar"          "application/x-rar-compressed"+   ,  x     ".rb"           "text/x-script.ruby"+   ,  x     ".rdf"          "application/rdf+xml"+   ,  x     ".roff"         "text/troff"+   ,  x     ".rpm"          "application/x-redhat-B.package-manager"+   ,  x     ".rss"          "application/rss+xml"+   ,  x     ".rtf"          "application/rtf"+   ,  x     ".ru"           "text/x-script.ruby"+   ,  x     ".s"            "text/x-asm"+   ,  x     ".sgm"          "text/sgml"+   ,  x     ".sgml"         "text/sgml"+   ,  x     ".sh"           "application/x-sh"+   ,  x     ".sig"          "application/pgp-signature"+   ,  x     ".snd"          "audio/basic"+   ,  x     ".so"           "application/octet-stream"+   ,  x     ".svg"          "image/svg+xml"+   ,  x     ".svgz"         "image/svg+xml"+   ,  x     ".swf"          "application/x-shockwave-flash"+   ,  x     ".t"            "text/troff"+   ,  x     ".tar"          "application/x-tar"+   ,  x     ".tbz"          "application/x-bzip-compressed-tar"+   ,  x     ".tcl"          "application/x-tcl"+   ,  x     ".tex"          "application/x-tex"+   ,  x     ".texi"         "application/x-texinfo"+   ,  x     ".texinfo"      "application/x-texinfo"+   ,  x     ".text"         "text/plain"+   ,  x     ".tif"          "image/tiff"+   ,  x     ".tiff"         "image/tiff"+   ,  x     ".torrent"      "application/x-bittorrent"+   ,  x     ".tr"           "text/troff"+   ,  x     ".txt"          "text/plain"+   ,  x     ".vcf"          "text/x-vcard"+   ,  x     ".vcs"          "text/x-vcalendar"+   ,  x     ".vrml"         "model/vrml"+   ,  x     ".war"          "application/java-archive"+   ,  x     ".wav"          "audio/x-wav"+   ,  x     ".wma"          "audio/x-ms-wma"+   ,  x     ".wmv"          "video/x-ms-wmv"+   ,  x     ".wmx"          "video/x-ms-wmx"+   ,  x     ".wrl"          "model/vrml"+   ,  x     ".wsdl"         "application/wsdl+xml"+   ,  x     ".xbm"          "image/x-xbitmap"+   ,  x     ".xhtml"        "application/xhtml+xml"+   ,  x     ".xls"          "application/vnd.ms-excel"+   ,  x     ".xml"          "application/xml"+   ,  x     ".xpm"          "image/x-xpixmap"+   ,  x     ".xsl"          "application/xml"+   ,  x     ".xslt"         "application/xslt+xml"+   ,  x     ".yaml"         "text/yaml"+   ,  x     ".yml"          "text/yaml"+   ,  x     ".zip"          "application/zip"+   ]+   where x a b = (a, b)
+ src/Hawk/Controller/Request.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleContexts #-}+module Hawk.Controller.Request+  ( getRequestMethod+  , getScriptName+  , getPathInfo+  , getEscapedPath+  , getQueryString+  , getServerName+  , getServerPort+  , getRequestHeaders+  , getRequestHeader+  , getReferer+  , getUrlScheme+  , getRequestBody+  , lookupParam+  , getParam+  , readParam+  , getParams+  , getParamsAsList+  ) where++import Control.Monad (liftM)+import Control.Monad.Reader +  ( MonadReader+  , asks+  )+import Data.ByteString.Lazy.UTF8 (toString)+import qualified Data.Map as M+import Hawk.Controller.Types+import Hawk.Controller.Util.Read+import Hawk.Controller.Util.Uri+  ( fromParamString+  , unescapeUri+  )++getRequestMethod :: (MonadReader RequestEnv m) => m RequestMethod+getRequestMethod = asks $ requestMethod . request++getScriptName :: (MonadReader RequestEnv m) => m String+getScriptName = asks $ scriptName . request++getPathInfo :: (MonadReader RequestEnv m) => m String+getPathInfo = asks $ pathInfo . request++getEscapedPath :: (MonadReader RequestEnv m) => m String+getEscapedPath = asks $ unescapeUri . pathInfo . request++getQueryString :: (MonadReader RequestEnv m) => m String+getQueryString = asks $ queryString . request++getServerName :: (MonadReader RequestEnv m) => m String+getServerName = asks $ serverName . request++getServerPort :: (MonadReader RequestEnv m) => m Int+getServerPort = asks $ serverPort . request++getRequestHeaders :: (MonadReader RequestEnv m) => m [(String, String)]+getRequestHeaders = asks $ http . request++getRequestHeader :: (MonadReader RequestEnv m) => String -> m (Maybe String)+getRequestHeader key = lookup key `liftM` getRequestHeaders++getReferer :: (MonadReader RequestEnv m) => m (Maybe String)+getReferer = getRequestHeader "Referer"++getUrlScheme :: (MonadReader RequestEnv m) => m Hack_UrlScheme+getUrlScheme = asks $ hackUrlScheme . request++getRequestBody :: (MonadReader RequestEnv m) => m ByteString+getRequestBody = asks $ hackInput . request++lookupParam :: HasState m => String -> m (Maybe String)+lookupParam key = M.lookup key `liftM` getParams++getParam :: HasState m => String -> m String+getParam key = M.findWithDefault "" key `liftM` getParams++readParam :: (HasState m, Read v) => String -> m (Maybe v)+readParam = liftM (>>= maybeRead) . lookupParam++getParams :: HasState m => m (M.Map String String)+getParams = extractParams `liftM` asks request++getParamsAsList :: HasState m => m [(String, String)]+getParamsAsList = M.toList `liftM` getParams++extractParams :: Env -> M.Map String String+extractParams e = M.fromList getReq `M.union` M.fromList postReq+  where+    getReq  = fromParamString $ queryString e+    postReq = fromParamString $ toString $ hackInput e
+ src/Hawk/Controller/Responses.hs view
@@ -0,0 +1,97 @@+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Bj�rn Peem�ller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   A set of standard responses+-}+-- --------------------------------------------------------------------------+module Hawk.Controller.Responses+  ( pageResponse+  , cachedResponse+  , redirectResponse+  , forbiddenResponse+  , notFoundResponse+  , errorResponse+  , addDefaultHeaders+  , addCustomHeaders+  , setHeader+  , addHeader+  , setStatus+  , isRedirect+  ) where++import Hack+import Network.HTTP.Headers (HeaderName(..))+import qualified Data.ByteString.Lazy.Char8 as B (length)+import Data.ByteString.Lazy (ByteString)+import Data.Default++setStatus :: Int -> Response -> Response+setStatus code response = response { status = code }++insertHeader :: String -> String -> ((String, String) -> Bool) -> Response -> Response+insertHeader h v p r = r { headers = (h, v) : filter p (headers r) }++setHeader :: HeaderName -> String -> Response -> Response+setHeader h v = insertHeader h' v ((/= h'). fst)+  where h' = show h++addHeader ::HeaderName -> String -> Response -> Response+addHeader h v = insertHeader (show h) v (const True)++addCustomHeaders :: [(String, String)] -> Response -> Response+addCustomHeaders hl r = r { headers = headers r ++ hl }++setBody :: ByteString -> Response -> Response+setBody content r = r { body = content }++htmlResponse :: ByteString -> Response -> Response+htmlResponse content = setHeader HdrContentType "text/html; charset=UTF-8" . setBody content++{-jsonResponse :: ByteString -> Response -> Response+jsonResponse content = setHeader HdrContentType "text/x-json; charset=UTF-8" . setBody content-}++pageResponse :: ByteString -> Response+pageResponse content = setStatus 200 $ htmlResponse content def+{-  case (shead content) of+    Just '{' -> jR+    Just '[' -> jR+    Just _ -> hR+    Nothing -> hR+  where shead l = if B.null l then Nothing else (Just $ B.head l)+        jR = setStatus 200 $ jsonResponse content def+        hR = setStatus 200 $ htmlResponse content def-}++cachedResponse :: Int -> String -> ByteString -> Response -> Response+cachedResponse age contentType content+  = setStatus 200+  . setHeader HdrCacheControl ("max-age=" ++ show age ++ ", public")+  . setHeader HdrContentType contentType+  . setBody content++redirectResponse :: String -> Response+redirectResponse location = setStatus 302 $ setHeader HdrLocation location def++isRedirect :: Response -> Bool+isRedirect = (== 302) . status++forbiddenResponse :: ByteString -> Response -> Response+forbiddenResponse content = setStatus 403 . htmlResponse content++notFoundResponse :: ByteString -> Response -> Response
+notFoundResponse content = setStatus 404 . htmlResponse content++errorResponse :: ByteString -> Response+errorResponse content = setStatus 500 $ htmlResponse content def++addDefaultHeaders :: Response -> Response+addDefaultHeaders response+  = setHeader HdrServer "Hawk"+  $ setHeader HdrContentLength (show $ B.length $ body response) response
+ src/Hawk/Controller/Routes.hs view
@@ -0,0 +1,73 @@+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   Routing+-}+-- --------------------------------------------------------------------------+module Hawk.Controller.Routes+  ( dispatch+  , simpleRouting+  , addUrlParams+  , urlFor+  , actionUrl+  , combine+  ) where++import Control.Monad (liftM)+import qualified Data.Map as M+import Hawk.Controller.Request+import Hawk.Controller.Types+import Hawk.Controller.Util.Text+import Hawk.Controller.Util.Uri++defaultAction :: String+defaultAction = "index"++defaultController :: String+defaultController = defaultAction++dispatch :: String -> Route+dispatch = withDefault . splitPath++withDefault :: Route -> Route+withDefault (Route c a) = Route defaultC defaultA+  where defaultA = if null a then defaultAction else a+        defaultC = if null c then defaultController else c++splitPath :: String -> Route+splitPath path = Route _controller _action+  where+      (_controller, _action) = getFirstTuple $ reduce $ splitAll (== '/') $ drop 1 path+      getFirstTuple []       = ([], [])+      getFirstTuple (x:[])   = (x, [])+      getFirstTuple (x:xs:_) = (x, xs) --TODO handle rest of path parameters+--    (_controller, _action) = splitWhere (== '/') $ drop 1 path++simpleRouting :: M.Map String (M.Map String Controller) -> Env -> Maybe Controller+simpleRouting m e = M.lookup c m >>= M.lookup a+  where (Route c a) = dispatch $ unescapeUri $ pathInfo e++addUrlParams :: [(String, String)] -> String -> String+addUrlParams ps = (++ toParamString ps)++urlFor :: HasState m => String -> m String+urlFor target = do+  sn <- getScriptName+  return $ escapeUri $ sn ++ target++actionUrl :: HasState m => String -> String -> [(String, String)] -> m String+actionUrl c a ps = addUrlParams ps `liftM` urlFor ('/':c ++ '/':a)++combine :: (Controller -> Controller) -> [Routing] -> [Routing]+combine _ []     = []+combine f (x:xs) = fx : combine f xs+        where fx = (fst x, f $ snd x)+
+ src/Hawk/Controller/Server.hs view
@@ -0,0 +1,147 @@+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   The main dispatcher.+-}+-- --------------------------------------------------------------------------+{-# LANGUAGE TemplateHaskell, Rank2Types #-}+module Hawk.Controller.Server ( requestHandler ) where++import Control.Exception ( SomeException )+import Control.Monad.CatchIO ( catch )+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Either+import Control.Monad.Trans()+import Data.ByteString.Lazy.UTF8 ( fromString )+import Data.Default+import qualified Data.Map as M+  ( null+  , toList+  )+import Database.HDBC ( ConnWrapper )+import Prelude hiding ( catch )+import qualified System.Log.Logger as Logger+import System.Log.Logger.TH ( deriveLoggers )++-- Hwak imports+import Hawk.Controller.Cookies+import Hawk.Controller.Responses+import Hawk.Controller.StateAccess+  ( setSessionValue+  , getSessionValue+  , deleteSessionKey+  , getSession+  , setSession+  )++import Hawk.Controller.Static+import Hawk.Controller.Types+import Hawk.Controller.Util.Read ( maybeRead )+++$(deriveLoggers "Logger" [Logger.DEBUG])++-- --------------------------------------------------------------------------+-- The request handler+-- --------------------------------------------------------------------------+-- | Runs the 'EnvController' from "Types" with the dispatching function +-- to process all requests "Hack" sends to the application+requestHandler :: (forall a m. (AppConfiguration a, MonadIO m) => m a)  -- ^ 'AppConfiguration' Type you defined in your application, $a$ is not known to Hawk+               -> ConnWrapper        -- ^ Database Connection+               -> BasicConfiguration -- ^ Hawk configuration type for its modules, e.g. Session, Authentication, etc. as well as base directories+               -> Options            -- ^+               -> Application+requestHandler app conn conf opts env = runReaderT (runController dispatch) (RequestEnv conn conf env opts app)++-- --------------------------------------------------------------------------+-- Private request handling functions+-- --------------------------------------------------------------------------+-- | Dispatch a 'Request' and return the 'Response'+dispatch :: EnvController Response+dispatch = liftM addDefaultHeaders+         $ handleExceptions+         $ staticRequest+         $ trace+         $ tryDynamic error404++-- | Catch any 'Exception's and return a server error response+handleExceptions :: EnvController Response -> EnvController Response+handleExceptions contr = contr `catch` handler+  where+    handler :: SomeException -> EnvController Response+    handler e = return $ errorResponse $ fromString $ "Internal server error: " ++ show e++-- | try to run dynamic content+tryDynamic :: EnvController Response -> EnvController Response+tryDynamic contr = do+  rtng <- asks $ routing . configuration+  req <- asks request+  case rtng req of+    Nothing       -> contr+    Just dynContr -> executeController dynContr+--    Just (dynContr, [m a -> m a]) -> ++executeController :: StateController ByteString -> EnvController Response+executeController = (\s -> evalStateT s def)+                  . manageHeaders+                  . withCookies+                  . withSession+                  . sessionFlash+                  . liftM (either id pageResponse)+                  . runEitherT++manageHeaders :: HasState m => m Response -> m Response+manageHeaders contr = do+  hdrs <- M.toList `liftM` gets responseHeaders+  addCustomHeaders hdrs `liftM` contr++-- | Trace the incoming request and the calculated response+trace :: EnvController Response -> EnvController Response+trace contr = do+  asks request >>= debugM . show+  res <- contr+  debugM $ show res+  return res++-- | Provide a session for the invoked controller+withSession :: (MonadIO m, HasState m) => m a -> m a+withSession contr = do+  config <- asks configuration+  let store = sessionStore config+  let opts  = sessionOpts  config+  sess <- readSession store opts+  debugM $ "Incoming session: " ++ show sess+  setSession sess+  res <- contr+  sess' <- getSession+  debugM $ "Outgoing session: " ++ show sess'+  saveSession store opts sess'+  return res++-- | Handle a flash persisted inside a session in case of redirects+sessionFlash :: HasState m => m Response -> m Response+sessionFlash contr = do+  -- get flash out of the session+  flashInSession <- getSessionValue flashKey+  case flashInSession >>= maybeRead of+    Nothing -> return ()+    Just f  -> do+      modify $ \s -> s { flash = f }+      deleteSessionKey flashKey+  -- run the controller+  response <- contr+  -- save flash to session if we have a redirect+  when (isRedirect response) $ do+      f <- gets flash+      unless (M.null f) (setSessionValue flashKey $ show f)+  return response+  where flashKey = "_flash"
+ src/Hawk/Controller/Session.hs view
@@ -0,0 +1,95 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+
+   Basic operations for sessions.
+-}
+-- --------------------------------------------------------------------------+module Hawk.Controller.Session+  ( Session (..)+  , SessionOpts+  , defaultName+  , emptySession+  , setSessionId+  , setExpiry+  , getValue+  , setValue+  , deleteKey+  , expired+  ) where
+
+import Control.Monad (liftM)++import Control.Monad.Trans+  ( MonadIO+  , liftIO+  )
++import Data.Time+  ( UTCTime+  , getCurrentTime+  )++import Data.Default++import qualified Data.Map as M+  ( Map+  , empty+  , lookup+  , insert+  , delete+  )
++-- | Options for 'Session's
+type SessionOpts = [(String, String)]++-- | A Session
+data Session = Session
+  { sessionId :: String
+  , expiry    :: Maybe UTCTime
+  , dataStore :: M.Map String String
+  } deriving (Read, Show)++instance Default Session where+  def = emptySession defaultName
++-- | The default name of a 'Session'+defaultName :: String+defaultName = "holsession"++-- | Create an empty 'Session' from an id
+emptySession :: String -> Session
+emptySession sId = Session sId Nothing M.empty
++-- | Set the id of a 'Session'
+setSessionId :: String -> Session -> Session
+setSessionId sId s = s { sessionId = sId }
++-- | Set the expiry time
+setExpiry :: Maybe UTCTime -> Session -> Session
+setExpiry time s = s { expiry = time }
++-- | Get a value from a 'Session'
+getValue :: String -> Session -> Maybe String
+getValue key = M.lookup key . dataStore
++-- | Set a value in the 'Session'
+setValue :: String -> String -> Session -> Session
+setValue k v s = s { dataStore = M.insert k v $ dataStore s }
++-- | Delete a key from the 'Session'
+deleteKey :: String -> Session -> Session
+deleteKey k s = s { dataStore = M.delete k $ dataStore s }
++-- | Checks whether a 'Session' is expired
+expired :: MonadIO m => Session -> m Bool
+expired s = case expiry s of
+  Nothing   -> return False
+  Just time -> liftM (> time) $ liftIO getCurrentTime
+ src/Hawk/Controller/Session/CookieSession.hs view
@@ -0,0 +1,98 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Bj�rn Peem�ller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+
+   Saving a session in cookies. Code is adapted from Alson Kemp's Turbinado.
+-}
+-- --------------------------------------------------------------------------+module Hawk.Controller.Session.CookieSession (cookieStore) where
++import Hawk.Controller.Types
+import Hawk.Controller.Session
+import Hawk.Controller.Cookies+import Hawk.Controller.Util.Read (maybeRead)+import Data.Digest.Pure.SHA (hmacSha256, bytestringDigest)+import Data.ByteString.Lazy.UTF8 (fromString, toString)+import Data.ByteString.Lazy (unpack, append)+import Data.Maybe (fromMaybe, fromJust)+import qualified Codec.Binary.Base64Url as Base64 (encode, decode)+import qualified Codec.Binary.UTF8.String as UTF8 (decode)+import Text.Regex.Posix (getAllTextSubmatches, (=~))+import Control.Monad.Trans (MonadIO)++secretMinLength :: Int+secretMinLength = 32 -- bytes+-- In rfc2104 a length of L strong random chars is suggested+-- L is the length of the hash output (for sha1 20; for sha224 28; for sha256 32)+-- a longer Key does not make the hmac more secure, becuase the key is hashed++cookieStore :: SessionStore+cookieStore = SessionStore+  { readSession   = readCookieSession+  , saveSession   = saveCookieSession
+  }++newCookieSession :: HasState m => SessionOpts -> m Session+newCookieSession opts =+  case secret opts of+    Nothing -> error "no secret in the cookie session options"+    Just s  -> if length s < secretMinLength then+                 error $ "secret must contain at least " ++ show secretMinLength ++ " characters"+                 else return $ emptySession $ sessionCookieName opts++readCookieSession :: (MonadIO m, HasState m) => SessionOpts -> m Session+readCookieSession opts = do
+    sessionCookie <- getCookieValue $ sessionCookieName opts
+    case sessionCookie >>= unmarshal (fromJust $ secret opts) >>= maybeRead of+      Nothing -> newCookieSession opts
+      Just s -> do+        e <- expired s+        if not e+           then return s
+           else newCookieSession opts++saveCookieSession :: HasState m => SessionOpts -> Session -> m ()+saveCookieSession opts sess =+  setCookie $ (newCookie (sessionId sess) marshalled) { cookiePath = Just "/" }+  where marshalled = marshal (fromJust $ secret opts) (show sess)++marshal :: String -> String -> String+marshal key s = toString $ encoded `append` fromString "--" `append` digest (fromString key) encoded+  where encoded = encode $ fromString s++-- TODO move to ByteString+unmarshal :: String -> String -> Maybe String+unmarshal key s+  | toString (digest (fromString key) (fromString content)) == sig = decode content+  | otherwise               = Nothing+  where+    [_, content, sig] = getAllTextSubmatches $ s =~ "^(.*)--(.*)$"++-- QuickCheck Idea: x == unmarshal k (marshal k x)++-- | Use a hmac to sign the Message with Key, the output is the base64url encoded hmac+digest :: ByteString -> ByteString -> ByteString+digest key = encode . bytestringDigest . hmacSha256 key++-- | Encode a UTF8 String to a Base64+encode :: ByteString -> ByteString+encode = fromString . Base64.encode . unpack++-- | Decode a Base64 String to a UTF8 String+decode :: String -> Maybe String+decode s = Base64.decode s >>= Just . UTF8.decode+--decode :: String -> Maybe ByteString+--decode s = Base64.decode s >>= Just . pack++secret :: SessionOpts -> Maybe String+secret = lookup "secret"++sessionCookieName :: SessionOpts -> String
+sessionCookieName = fromMaybe defaultName . lookup "cookie-name"
+ src/Hawk/Controller/Session/DatabaseSession.hs view
@@ -0,0 +1,75 @@+-- --------------------------------------------------------------------------
+{- |+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2010 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+   
+   Maintainer  :  inf6254@fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+  
+   Saving a session in the database.
+-}
+-- --------------------------------------------------------------------------+module Hawk.Controller.Session.DatabaseSession (databaseStore) where
++import Data.Maybe (fromMaybe)+import Data.Time (UTCTime)
+import Hawk.Controller.Types
+import Hawk.Controller.Session
+import Hawk.Controller.Cookies+import Hawk.Controller.Util.Read (maybeRead)+import Hawk.Model++databaseStore :: SessionStore+databaseStore = SessionStore+  { readSession   = readDatabaseSession+  , saveSession   = saveDatabaseSession
+  }++data RawSession = RawSession+  { rs_id     :: Integer+  , rs_expiry :: Maybe UTCTime+  , rs_data   :: String+  }++instance Persistent RawSession where+  persistentType _             = "Session"+  fromSqlList (l0:l1:l2:[])    = RawSession (fromSql l0) (fromSql l1) (fromSql l2)+  fromSqlList _                = error "wrong list length"+  toSqlAL raw                  = [ ("_id"   , toSql $ rs_id     raw)+                                 , ("expiry", toSql $ rs_expiry raw)+                                 , ("data"  , toSql $ rs_data   raw)+                                 ]                                 +  tableName                    = const "session"++instance WithPrimaryKey RawSession where+  primaryKey = rs_id+  pkColumn _ = "_id"+  setPrimaryKey pk raw = raw { rs_id = pk }++toRaw :: Session -> RawSession+toRaw s = RawSession (read $ sessionId s) (expiry s) (show $ dataStore s)++fromRaw :: RawSession -> Session+fromRaw raw = Session (show $ rs_id raw) (rs_expiry raw) (read $ rs_data raw)++newDatabaseSession :: HasState m => m Session+newDatabaseSession = do+  rs <- insertByPK $ toRaw $ emptySession "0"+  commit+  return $ fromRaw rs++readDatabaseSession :: HasState m => SessionOpts -> m Session+readDatabaseSession opts = do
+  sId <- getCookieValue $ sessionCookieName opts+  return (sId >>= maybeRead) >>= maybe (return Nothing) findMaybeByPK >>= maybe newDatabaseSession (return . fromRaw)++saveDatabaseSession :: HasState m => SessionOpts -> Session -> m ()+saveDatabaseSession opts sess = do+  updateByPK (toRaw sess) >> commit+  setCookie $ (newCookie (sessionCookieName opts) (sessionId sess)) { cookiePath = Just "/" }++sessionCookieName :: SessionOpts -> String
+sessionCookieName = fromMaybe defaultName . lookup "sessionId"
+ src/Hawk/Controller/Session/NoSession.hs view
@@ -0,0 +1,28 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+
+   Does not save the session
+-}
+-- --------------------------------------------------------------------------+module Hawk.Controller.Session.NoSession where
++import Hawk.Controller.Types
+import Hawk.Controller.Session
++noSession :: SessionStore+noSession = SessionStore +  { -- readSession   :: s -> SessionOpts -> m Session+    readSession = \_ -> return $ emptySession "emptySession"+
+  , -- saveSession   :: s -> SessionOpts -> Session -> m ()+    saveSession = \_ _ -> return ()+  }+
+ src/Hawk/Controller/StateAccess.hs view
@@ -0,0 +1,69 @@+module Hawk.Controller.StateAccess where++import Control.Monad (liftM)+import Control.Monad.State+  ( modify+  , gets+  )+import Control.Monad.Trans (MonadIO)+import qualified Data.Map as M+import Data.Time (UTCTime)+import Hawk.Controller.Session+import Hawk.Controller.Types+import Hawk.Controller.Util.Read++setHeader :: HasState m => String -> String -> m ()+setHeader k v = modify $ \s -> s { responseHeaders = M.insert k v $ responseHeaders s }++setFlash :: HasState m => String -> String -> m ()+setFlash key msg = modify $ \s -> s { flash = M.insert key msg $ flash s }++getFlash :: HasState m => String -> m (Maybe String)+getFlash key = gets $ M.lookup key . flash++setErrors :: HasState m => String -> [(String, String)] -> m ()+setErrors key errs = modify $ \s -> s { errors = M.insert key errs $ errors s }++getErrors :: HasState m => String -> m [(String, String)]+getErrors key = gets $ M.findWithDefault [] key . errors++-- --------------------------------------------------------------------------+-- Session+-- --------------------------------------------------------------------------+getSession :: HasState m => m Session+getSession = gets session++setSession :: HasState m => Session -> m ()+setSession sess = modify $ \s -> s { session = sess }++getSessionValue :: HasState m => String -> m (Maybe String)+getSessionValue key = gets $ getValue key . session++readSessionValue :: (HasState m, Read v) => String -> m (Maybe v)+readSessionValue = liftM (>>= maybeRead) . getSessionValue++setSessionValue :: HasState m => String -> String -> m ()+setSessionValue k v = do+  sess <- getSession+  modify $ \s -> s { session = setValue k v sess }++deleteSessionKey :: HasState m => String -> m ()+deleteSessionKey key = do+  sess <- getSession+  modify $ \s -> s { session = deleteKey key sess }++clearSession :: HasState m => m ()+clearSession = do+  sess <- getSession+  modify $ \s -> s { session = emptySession (sessionId sess) }++sessionExpired :: (HasState m, MonadIO m) => m Bool+sessionExpired = getSession >>= expired++getSessionExpiry :: HasState m => m (Maybe UTCTime)+getSessionExpiry = gets $ expiry . session++setSessionExpiry :: HasState m => Maybe UTCTime -> m ()+setSessionExpiry e = do+  sess <- getSession+  modify $ \s -> s { session = setExpiry e sess }
+ src/Hawk/Controller/Static.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell #-}+module Hawk.Controller.Static+    ( error404+    , error404Response+    , error401+    , error401Response+    , error500+    , error500Response+    , staticRequest+    ) where++import Hawk.Controller.Types+import Hawk.Controller.Responses+import Hawk.Controller.Mime++import System.Directory (doesFileExist, getPermissions, Permissions(readable))+import System.FilePath (takeExtension)+import Data.ByteString.Lazy.UTF8 (fromString)+import qualified Data.ByteString.Lazy as BS (readFile)+import Data.List (isInfixOf)+import Control.Monad.Either+import Control.Monad.Reader (asks)+import Data.Default+import Hawk.Controller.Util.Uri (unescapeUri)++import qualified System.Log.Logger as Logger+import System.Log.Logger.TH (deriveLoggers)++$(deriveLoggers "Logger" [Logger.WARNING])++-- | return a 404 File not found error. I the file could not be found raise a error500+error404 :: EnvController Response+error404 = asks ((++) "/" . error404file . configuration)+    >>= tryStatic+    >>= maybe (warningM "could not find error 404 file" >> error500) (return . setStatus 404)++error404Response :: StateController a+error404Response = lift (lift error404) >>= returnLeft++error401 :: EnvController Response+error401 = asks ((++) "/" . error401file . configuration)+    >>= tryStatic+    >>= maybe (warningM "could not find error 401 file" >> error500) (return . setStatus 401 . addCustomHeaders [("WWW-Authenticate", "Basic")])++error401Response :: StateController a+error401Response = lift (lift error401) >>= returnLeft++-- | return a 500 internal server error+error500 :: EnvController Response+error500 = asks ((++) "/" . error500file . configuration)+    >>= tryStatic+    >>= maybe (warningM "could not find error 500 file" >> return (errorResponse m)) (return . setStatus 500)+    where+    m = fromString "Internal Server Error 500"++error500Response :: StateController a+error500Response = lift (lift error500) >>= returnLeft++staticRequest :: EnvController Response -> EnvController Response+staticRequest contr = do+  path <- asks $ unescapeUri . pathInfo . request+  isStatic <- tryStatic path+  case isStatic of+    Nothing -> contr+    Just r  -> return r++-- | try to deliver static content from the public dir+tryStatic :: String -> EnvController (Maybe Response)+tryStatic path =+  if ".." `isInfixOf` path -- TODO make a real check if dir is sub dir+    then return $ Just $ forbiddenResponse (fromString path) def+    else do+      let path' = if path == "/" then "/index.xhtml" else path+      pDir <- asks $ publicDir . configuration+      let fullPath = pDir ++ path'+      fileExists <- liftIO $ doesFileExist fullPath+      if fileExists+        then do+          canRead <- liftIO $ liftM readable $ getPermissions fullPath+          if canRead+            then do+              file <- liftIO $ BS.readFile fullPath+              return $ Just $ cachedResponse 600 (getMimeType $ takeExtension fullPath) file def+            else return $ Just $ forbiddenResponse (fromString path) def+        else return Nothing
+ src/Hawk/Controller/Types.hs view
@@ -0,0 +1,162 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+
+   Provides library-wide used Types and Classes
+-}
+-- --------------------------------------------------------------------------
+{-# LANGUAGE Rank2Types, FlexibleContexts, FlexibleInstances,
+    GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-}
+module Hawk.Controller.Types
+  ( Options
+  , BasicConfiguration (..)
+  , RequestEnv (..)
+  , ResponseState (..)
+  , HasState
+  , module Hack
+
+  , AppConfiguration (..)
+
+  , EnvController (..)
+  , StateController
+
+  , View (..)
+
+  , module Hawk.Controller.Auth.ResultType 
+  , AuthType
+  , SessionStore (..)
+  , Route (..)
+  , Routing
+  , Controller
+  , ByteString
+  ) where
+
+import Hawk.Controller.Session
+  ( Session
+  , SessionOpts
+  )
+
+import Hawk.Controller.Auth.ResultType
+
+import Hawk.Model.MonadDB ( MonadDB (..) )
+
+import Control.Monad.CatchIO ( MonadCatchIO (..) )
+import Control.Monad.Either
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans()
+import Data.ByteString.Lazy ( ByteString )
+import Data.Default
+import Data.Map (Map)
+import Database.HDBC ( ConnWrapper )
+import Hack
+import Network.CGI.Cookie ( Cookie )
+
+-- --------------------------------------------------------------------------
+-- Options, BasicConfiguration, ResponseEnv, ResponseState
+-- --------------------------------------------------------------------------
+type Options = [(String, String)]
+
+data BasicConfiguration = BasicConfiguration
+  { sessionStore :: SessionStore
+  , sessionOpts  :: SessionOpts
+  , authType     :: AuthType
+  , authOpts     :: [String]
+  , routing      :: Hack.Env -> Maybe Controller
+  , templatePath :: String
+  , publicDir    :: String
+  , error401file :: String
+  , error404file :: String
+  , error500file :: String
+  , confOptions  :: Options
+  }
+
+data RequestEnv = RequestEnv
+  { databaseConnection :: ConnWrapper
+  , configuration      :: BasicConfiguration
+  , request            :: Hack.Env
+  , environmentOptions :: Options
+  , appConfiguration   :: (AppConfiguration a, MonadIO m) => m a -- type defined by application
+  }
+
+data ResponseState = ResponseState
+  { session            :: Session
+  , cookies            :: [Cookie]
+  , responseHeaders    :: Map String String
+  , flash              :: Map String String
+  , errors             :: Map String [(String, String)]
+  }
+
+instance Default ResponseState where def = ResponseState def def def def def
+
+class ( MonadReader RequestEnv m, MonadState ResponseState m, MonadCatchIO m ) => HasState m where
+
+instance (MonadReader RequestEnv m, MonadCatchIO m) => MonadDB m where
+  getConnection = asks databaseConnection
+
+-- --------------------------------------------------------------------------
+-- EnvController
+-- --------------------------------------------------------------------------
+newtype EnvController a
+  = EnvController { runController :: ReaderT RequestEnv IO a }
+  deriving (Functor, Monad, MonadIO, MonadCatchIO, MonadReader RequestEnv)
+
+--instance MonadDB EnvController where getConnection = asks databaseConnection
+
+-- --------------------------------------------------------------------------
+-- StateController
+-- --------------------------------------------------------------------------
+type StateController = EitherT Response (StateT ResponseState EnvController)
+
+instance HasState (StateT ResponseState EnvController) where
+
+instance HasState (EitherT e (StateT ResponseState EnvController)) where
+--instance MonadDB (EitherT e (StateT ResponseState EnvController)) where
+--  getConnection = lift $ lift getConnection
+
+-- --------------------------------------------------------------------------
+-- Rendering
+-- --------------------------------------------------------------------------
+class View a where
+  type Target a :: *
+  render :: a -> Target a -> StateController ByteString
+
+-- --------------------------------------------------------------------------
+-- SessionStore
+-- --------------------------------------------------------------------------
+data SessionStore = SessionStore
+  { readSession   :: (MonadIO m, HasState m) => SessionOpts -> m Session
+  , saveSession   :: (MonadIO m, HasState m) => SessionOpts -> Session -> m ()
+  }
+
+-- --------------------------------------------------------------------------
+-- Authentication
+-- --------------------------------------------------------------------------
+type AuthType = (MonadDB m, MonadIO m, HasState m) => m AuthResult
+
+-- --------------------------------------------------------------------------
+-- Routing
+-- --------------------------------------------------------------------------
+data Route = Route
+  { routeController :: String
+  , routeAction     :: String
+  } deriving (Show)
+
+type Routing = (String, Controller)
+type Controller = StateController ByteString
+
+-- --------------------------------------------------------------------------
+-- AppConfig
+-- --------------------------------------------------------------------------
+class AppConfiguration a where
+  getInstance :: MonadIO m => m a
+
+instance AppConfiguration () where
+  getInstance = return ()
+ src/Hawk/Controller/Util/List.hs view
@@ -0,0 +1,28 @@+module Hawk.Controller.Util.List+    ( splitAll+    , splitWhere+    , lookupFirst+    , replaceOrAdd+    ) where++splitAll :: (a -> Bool) -> [a] -> [[a]]+splitAll _ [] = []+splitAll p xs = f : splitAll p s+  where (f, s) = splitWhere p xs++splitWhere :: (a -> Bool) -> [a] -> ([a], [a])+splitWhere p xs = (f, drop 1 s)+  where (f, s) = break p xs++-- lookupFirst = safeHead . filter p+lookupFirst :: (a -> Bool) -> [a] -> Maybe a+lookupFirst _ [] = Nothing+lookupFirst p (x:xs)+  | p x       = Just x+  | otherwise = lookupFirst p xs++replaceOrAdd :: (a -> a -> Bool) -> a -> [a] -> [a]+replaceOrAdd _ new [] = [new]+replaceOrAdd eq new (x:xs)+  | new `eq` x = new : xs+  | otherwise  = x : replaceOrAdd eq new xs
+ src/Hawk/Controller/Util/Monad.hs view
@@ -0,0 +1,30 @@+module Hawk.Controller.Util.Monad+    ( concatMapM+    , untilJustM+    , liftMaybe+    , ap' )+    where++import Control.Monad (liftM)+++concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f = liftM concat . mapM f+--foldr (liftM2 (++) . f) $ return []++-- | runs a List of monadic Maybe operations until one return Just+-- If no return Just a default is return+untilJustM :: Monad m => m a -> [m (Maybe a)] -> m a+untilJustM a []     = a+untilJustM a (x:xs) = x >>= maybe (untilJustM a xs) return++liftMaybe :: Monad m => (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)+liftMaybe = maybe (return Nothing)++-- | Like Control.Monad.ap, but runs first m a and then m (a -> b)+ap' :: Monad m => m (a -> b) -> m a -> m b+ap' f m = do+    m' <- m+    f' <- f+    return $ f' m'+
+ src/Hawk/Controller/Util/Read.hs view
@@ -0,0 +1,6 @@+module Hawk.Controller.Util.Read where++import Data.Maybe (listToMaybe)++maybeRead :: Read a => String -> Maybe a+maybeRead = listToMaybe . map fst . filter (null . snd) . reads
+ src/Hawk/Controller/Util/Text.hs view
@@ -0,0 +1,56 @@+module Hawk.Controller.Util.Text+    ( firstLower+    , firstUpper+    , first+    , toUnderscore+    , toCamelCase+    , toAllLower+    , splitAll+    , splitWhere+    , reduce+    ) where++import Data.Char (toLower, toUpper, isUpper)++-- | convert the first char to a lower+firstLower :: String -> String+firstLower = first toLower++-- | convert the first char to a upper+firstUpper :: String -> String+firstUpper = first toUpper++-- | Apply a function to the first element of a list+first :: (a -> a) -> [a] -> [a]+first _ []     = []+first f (x:xs) = f x : xs++toUnderscore :: String -> String+toUnderscore [] = []+toUnderscore string@(c:cs)+  | isUpper c = '_' : toUnderscore (firstLower string)+  | otherwise =  c  : toUnderscore cs++toCamelCase :: Char -> String -> String+toCamelCase _ [] = []+toCamelCase sep (c:cs)+  | c == sep  = firstUpper $ toCamelCase sep cs+  | otherwise = c : toCamelCase sep cs++toAllLower :: String -> String+toAllLower = map toLower++splitAll :: (a -> Bool) -> [a] -> [[a]]+splitAll _ [] = []+splitAll p xs = f : splitAll p s+  where (f, s) = splitWhere p xs++splitWhere :: (a -> Bool) -> [a] -> ([a], [a])+splitWhere p xs = (f, drop 1 s)+  where (f, s) = break p xs++reduce :: [[a]] -> [[a]]+reduce ([])    = []+reduce ([]:xs) = reduce xs+reduce (x:xs)  = x : reduce xs+
+ src/Hawk/Controller/Util/Uri.hs view
@@ -0,0 +1,39 @@+module Hawk.Controller.Util.Uri+  ( escapeUri+  , unescapeUri+  , fromParamString+  , toParamString+  ) where++import Data.List (intercalate)+import Network.URI+    ( escapeURIString+    , isAllowedInURI+    , unEscapeString+    )+import Hawk.Controller.Util.Text +  ( splitWhere+  , splitAll+  )++escapeUri :: String -> String+escapeUri = escapeURIString isAllowedInURI++unescapeUri :: String -> String+unescapeUri = unEscapeString . unescapeSpace++unescapeSpace :: String -> String+unescapeSpace = map (\c -> if c == '+' then ' ' else c)++fromParamString :: String -> [(String, String)]+fromParamString = map (unescapePair . splitWhere (== '=')) . splitAll (== '&')++unescapePair :: (String, String) -> (String, String)+unescapePair (a, b) = (unescapeUri a, unescapeUri b)++toParamString :: [(String, String)] -> String+toParamString [] = []+toParamString ls = '?' : intercalate "&" (map ((\(a, b) -> a ++ '=' : b) . escapePair) ls)++escapePair :: (String, String) -> (String, String)+escapePair (a, b) = (escapeUri a, escapeUri b)
+ src/Hawk/Model.hs view
@@ -0,0 +1,37 @@+module Hawk.Model+  ( -- * Basic modules+    module Hawk.Model.Criteria+  , module Hawk.Model.CriteriaSelect+  , module Hawk.Model.MonadDB+  , module Hawk.Model.Types+  , module Hawk.Model.Util++    -- * Default mapping+  , module Hawk.Model.Persistent+  , module Hawk.Model.WithPrimaryKey+  , module Hawk.Model.WithForeignKey++    -- * Model access+  , module Hawk.Model.Model+  , module Hawk.Model.Association++    -- * Validation+  , module Hawk.Model.Updater+  , module Hawk.Model.Validator+  ) where++import Hawk.Model.Criteria+import Hawk.Model.CriteriaSelect+import Hawk.Model.MonadDB+import Hawk.Model.Types+import Hawk.Model.Util++import Hawk.Model.Persistent+import Hawk.Model.WithPrimaryKey+import Hawk.Model.WithForeignKey++import Hawk.Model.Model+import Hawk.Model.Association++import Hawk.Model.Updater+import Hawk.Model.Validator
+ src/Hawk/Model/Association.hs view
@@ -0,0 +1,53 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+
+-}
+-- --------------------------------------------------------------------------++{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}++module Hawk.Model.Association
+    ( BelongsTo (..)+    , HasMany   (..)+    , HasOne    (..)
+    ) where
+
+import Hawk.Model.MonadDB+import Hawk.Model.WithForeignKey
++class ForeignKeyRelationship r => BelongsTo r where+  getMaybeParent :: MonadDB m => r -> Referencing r -> m (Maybe (Referenced r))+  getParent      :: MonadDB m => r -> Referencing r -> m (Referenced r)+  setParent      :: MonadDB m => r -> Referencing r -> (Maybe (Referenced r)) -> m (Referencing r)++  getMaybeParent = getMaybeReferenced+  getParent      = getOneReferenced+  setParent      = setReferenced+++class ForeignKeyRelationship r => HasMany r where+  getChildren :: MonadDB m => r -> Referenced r -> m [Referencing r]+  addChild    :: MonadDB m => r -> Referenced r -> Referencing r -> m (Referencing r)+  removeChild :: MonadDB m => r -> Referenced r -> Referencing r -> m (Referencing r)++  getChildren = getReferencings+  addChild    = addReferencing+  removeChild = removeReferencing++-- TODO Signatur festzurren!+class ForeignKeyRelationship r => HasOne r where+  getMaybeChild :: MonadDB m => r -> Referenced r -> m (Maybe (Referencing r))+  getChild      :: MonadDB m => r -> Referenced r -> m (Referencing r)+  replaceChild  :: MonadDB m => r -> Referenced r -> Maybe (Referencing r) -> m (Maybe (Referencing r),Maybe (Referencing r))++  getMaybeChild = getMaybeReferencing+  getChild      = getOneReferencing+  replaceChild  = replaceReferencing
+ src/Hawk/Model/Criteria.hs view
@@ -0,0 +1,27 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Criteria.hs 291 2009-05-01 13:01:55Z inf6509 $++   A Hibernate inspired SQL Query api data, this module rexport all needed types and functions.
+-}
+-- ----------------------------------------------------------------------------+module Hawk.Model.Criteria+    ( module Hawk.Model.Criteria.Criteria+    , module Hawk.Model.Criteria.Projection+    , module Hawk.Model.Criteria.Restriction+    , module Hawk.Model.Criteria.Order+    , toExprPair+    ) where++import Hawk.Model.Criteria.Criteria+import Hawk.Model.Criteria.Projection+import Hawk.Model.Criteria.Restriction+import Hawk.Model.Criteria.Order+import Hawk.Model.Criteria.Types
+ src/Hawk/Model/Criteria/Criteria.hs view
@@ -0,0 +1,259 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Criteria.hs 291 2009-05-01 13:01:55Z inf6509 $++   Function for working with the whole Criteria data
+-}
+-- ----------------------------------------------------------------------------+module Hawk.Model.Criteria.Criteria+    (+    -- * Criteria+    Criteria (..)+    , setRestriction+    , newCriteria+    , restrictionCriteria+    , addExtra+    , addLimit+    , setOrder+    -- * Query+    , Query (..)+    , newSelect+    , setOption+    , setCriteria+    , setProjection+    , setTables+    , setGrouping+    , setHaving+    , modifyCriteria+    -- * Manipulation+    , Manipulation (..)+    , newDelete+    , newUpdate+    , newInsert+    , setManipulationCriteria+    , modifyManipulationCriteria+    , setTable+    , setSet+    , setValues+    ) where++import Hawk.Model.Criteria.Types+import Hawk.Model.Criteria.Projection+import Hawk.Model.Criteria.Restriction+import Hawk.Model.Criteria.Order+import Data.List (intercalate)
++data Criteria = Criteria+    { restriction :: Maybe Restriction -- ^ WHERE+    , ordering    :: [Order]           -- ^ ORDER BY+    , extra       :: [String]          -- ^ LIMIT, OFFSET, ...+    }++data Query = Select+    { option     :: Maybe String      -- ^ ALL, DISTINCT, ...+    , projection :: [Projection]      -- ^ SELECT+    , tables     :: [TableName]       -- ^ FROM+    , grouping   :: [ColumnName]      -- ^ GROUP BY+    , having     :: Maybe Restriction -- ^ HAVING+    , criteria   :: Criteria          -- ^ WHERE, ORDER BY and LIMIT, OFFSET, ...+    }++data Manipulation =+      Delete+        { table    :: TableName+        , manipulationCriteria :: Criteria+        }+    | Update+        { table    :: TableName+        , set      :: [(ColumnName, SqlValue)]+        , manipulationCriteria :: Criteria+        }+    | Insert+        { table    :: TableName+        , values   :: [(ColumnName, SqlValue)]+        }++instance ShowSql Criteria where+    showSql c = whereClause (restriction c)+            ++ orderClause (ordering c)+            ++ extraClause (extra c)+        where+        whereClause r     = case r of+                          Nothing -> []+                          Just rs -> " WHERE " ++ showSql rs+        orderClause o     = case o of+                          [] -> ""+                          os -> " ORDER BY " ++ intercalate ", " (map showSql os)+        extraClause e     = ' ' : intercalate ", " e++instance ShowSql Query where+  showSql c =  optionsClause (option                 c)+            ++ selectClause  (projection             c)+            ++ fromClause    (tables                 c)+            ++ whereClause   (restriction $ criteria c)+            ++ groupClause   (grouping               c)+            ++ orderClause   (ordering    $ criteria c)+            ++ havingClause  (having                 c)+            ++ extraClause   (extra       $ criteria c)+      where+      optionsClause opt = case opt of+                          Nothing -> "SELECT"+                          Just o  -> "SELECT " ++ o+      selectClause proj = case proj of+                          [] -> " *"+                          p  -> ' ' : intercalate ", " (map showSql p)++      fromClause tbls   = " FROM " ++ intercalate ", " tbls+      whereClause r     = case r of+                          Nothing -> []+                          Just rs -> " WHERE " ++ showSql rs+      groupClause g     = case g of+                          [] -> ""+                          gs -> " GROUP BY " ++ intercalate ", " gs+      orderClause o     = case o of+                          [] -> ""+                          os -> " ORDER BY " ++ intercalate ", " (map showSql os)+      havingClause h    = case h of+                          Nothing -> []+                          Just hs -> " HAVING " ++ showSql hs+      extraClause e     = ' ' : intercalate ", " e++instance ShowSql Manipulation where+  showSql (Delete t   c) = showDelete t   c+  showSql (Update t s c) = showUpdate t s c+  showSql (Insert t s  ) = showInsert t s++showDelete :: TableName -> Criteria -> String+showDelete tbl cri =+    deleteClause ++ showSql cri+    where+        deleteClause = "DELETE FROM " ++ tbl++showUpdate :: TableName -> [(ColumnName, SqlValue)] -> Criteria -> String+showUpdate tbl s cri =+    updateClause ++ columnExpr ++ showSql cri+    where+        updateClause = "UPDATE " ++ tbl+        columnExpr   = " SET " ++ intercalate ", " (map (\(cn,_) -> cn ++ " = ? ") s)++showInsert :: TableName -> [(ColumnName, SqlValue)] -> String+showInsert tbl s =+    insertClause ++ columns ++ value+    where+        insertClause = "INSERT INTO " ++ tbl+        columns      = " (" ++ intercalate ", " (map fst s) ++ ")"+        value        = " VALUES (" ++ intercalate ", " (map (const "?") s) ++ ")"++instance GetValues Criteria where+    getValues = maybe [] getValues . restriction++instance GetValues Query where+    getValues (Select _ _ _ _ h c) = getValues c ++ maybe [] getValues h++instance GetValues Manipulation where+    getValues (Delete _ c) = getValues c+    getValues (Update _ s c) = map snd s ++ getValues c+    getValues (Insert _ s) = map snd s++-- * Criteria functions++-- | Create a empty Criteria+newCriteria :: Criteria+newCriteria = Criteria Nothing [] []++restrictionCriteria :: Restriction -> Criteria+restrictionCriteria r = setRestriction r newCriteria++-- | Set the Restriction of a Criteria (sql where clause)+setRestriction :: Restriction -> Criteria -> Criteria+setRestriction r c = c {restriction = Just r}++-- | Set the Order of a Criteria (sql order by clause)+setOrder :: [Order] -> Criteria -> Criteria+setOrder o c = c {ordering = o}++-- | Set the Extra of a Criteria (sql limit, offset, etc.)+addExtra :: String -> Criteria -> Criteria+addExtra e c = c { extra = e : extra c }++-- | Set the Projection of a Selct (sql select clause)+setProjection :: [Projection] -> Query -> Query+setProjection p c = c {projection = p}++-- * Query functions++-- | Create a empty Select+newSelect :: Query+newSelect = Select Nothing [] [] [] Nothing newCriteria++-- | Set the select Option (ALL, DISTINCT)+setOption :: String -> Query -> Query+setOption o q = q {option = Just o}++-- | Set the criteria+setCriteria :: Criteria -> Query -> Query+setCriteria c q = q {criteria = c}++-- | apply a funktion to the containing Criteria+modifyCriteria :: (Criteria -> Criteria) -> Query -> Query+modifyCriteria f q = q {criteria = f $ criteria q}++-- | Set a limit for the query+addLimit :: Int -> Int -> Criteria -> Criteria+addLimit start cnt = addExtra $ "LIMIT " ++ show start ++ ", " ++ show cnt++-- | Set the Tables of a Criteria (sql where clause)+setTables :: [TableName] -> Query -> Query+setTables t c = c {tables = t}++-- | Set the Grouoing of a Criteria (sql group by clause)+setGrouping :: [ColumnName] -> Query -> Query+setGrouping g c = c {grouping = g}++-- | Set the Restriction of a Criteria (sql having clause)+setHaving :: Restriction -> Query -> Query+setHaving h c = c {having = Just h}++-- * Manipulation functions++-- | Create a new DELETE sql+newDelete :: TableName -> Manipulation+newDelete t = Delete t newCriteria++-- | Create a new UPDATE sql+newUpdate :: TableName -> Manipulation+newUpdate t = Update t [] newCriteria++-- | Create a new INSERT sql+newInsert :: TableName -> Manipulation+newInsert t = Insert t []++-- | Set the criteria+setManipulationCriteria :: Criteria -> Manipulation -> Manipulation+setManipulationCriteria c m = m {manipulationCriteria = c}++-- | apply a funktion to the containing Criteria+modifyManipulationCriteria :: (Criteria -> Criteria) -> Manipulation -> Manipulation+modifyManipulationCriteria _ m@(Insert _ _) = m+modifyManipulationCriteria f q = q {manipulationCriteria = f $ manipulationCriteria q}++-- | set the Table name to a different value+setTable :: TableName -> Manipulation -> Manipulation+setTable t c = c {table = t}++-- | set the Column value combination for a UPDATE sql+setSet :: [(ColumnName, SqlValue)] -> Manipulation -> Manipulation+setSet s u@(Update _ _ _) = u {set = s}+setSet _ m = m++-- | set the Column value combination for a INSERT sql+setValues :: [(ColumnName, SqlValue)] -> Manipulation -> Manipulation+setValues v u@(Insert _ _) = u {values = v}+setValues _ m = m
+ src/Hawk/Model/Criteria/Order.hs view
@@ -0,0 +1,41 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Order.hs 291 2009-05-01 13:01:55Z inf6509 $++   The order part (ORDER BY) of the criteria api
+-}
+-- ----------------------------------------------------------------------------+module Hawk.Model.Criteria.Order+    ( Order+    , asc+    , desc+    ) where++import Hawk.Model.Criteria.Types++data OrderType = Asc+               | Desc++data Order = Order OrderType ColumnName++-- | Sort Ascending by the column+asc :: ColumnName -> Order+asc = Order Asc++-- | Sort Descending by the column+desc :: ColumnName -> Order+desc = Order Desc++instance ShowSql OrderType where+  showSql Asc  = " ASC"+  showSql Desc = " DESC"++instance ShowSql Order where+  showSql (Order o c) = c ++ showSql o
+ src/Hawk/Model/Criteria/Projection.hs view
@@ -0,0 +1,93 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Projection.hs 291 2009-05-01 13:01:55Z inf6509 $++   Projection for the criteria api
+-}
+-- ----------------------------------------------------------------------------+module Hawk.Model.Criteria.Projection+  ( Projection+  , colP, asP+  , rowCountP, countP+  , sumP, avgP+  , minP, maxP+  , customP+  ) where++import Hawk.Model.Criteria.Types++-- | The Data for Aggregate Functions+data Op = Count+        | Sum+        | Avg+        | Min+        | Max+        | Custom String++-- | A Projection is the defnintion for one Column+data Projection = Projection+  { as     :: Maybe ColumnName -- ^ rename a column (@AS@)+  , op     :: Maybe Op         -- ^ Operation (@COUNT@, @SUM@, @AVG@ ...)+  , column :: ColumnName       -- ^ the column name+  }++-- | Creates a SimpleProject from a Name+colP :: ColumnName -> Projection+colP = Projection Nothing Nothing++-- | Counts how many rows are in the table+rowCountP :: Projection+rowCountP = countP "*"++-- | Count how many rows have not @NULL@ Value in the given Column.+countP :: ColumnName -> Projection+countP = Projection Nothing $ Just Count++-- (TODO what happen if NULL is returnd)+-- | Sums all values in the column. Gives @NULL@ if one Column ist @NULL@.+sumP :: ColumnName -> Projection+sumP = Projection Nothing $ Just Sum++-- | Return the average value of all non-@NULL@ values in the column.+avgP :: ColumnName -> Projection+avgP = Projection Nothing $ Just Avg++-- | Return the minimum non-@NULL@ value of all values in the column.+minP :: ColumnName -> Projection+minP = Projection Nothing $ Just Min++-- | Return the maximum value of all values in the column.+maxP :: ColumnName -> Projection+maxP = Projection Nothing $ Just Max++-- | Apply a custom SQL-Function+customP :: String -> ColumnName -> Projection+customP =  Projection Nothing .  Just . Custom++-- | Give a SimpleProjection a other Name.+asP :: ColumnName -> Projection -> Projection+asP a p = p { as = Just a }++instance ShowSql Op where+  showSql Count      = "COUNT"+  showSql Sum        = "SUM"+  showSql Avg        = "AVG"+  showSql Min        = "MIN"+  showSql Max        = "MAX"+  showSql (Custom c) = c++instance ShowSql Projection where+  showSql p = case op p of+            Just o' -> showSql o' ++ paren (column p) ++ showAs (as p)+            Nothing -> column p ++ showAs (as p)+    where showAs = maybe "" ((++) " AS ")++paren :: String -> String+paren s = '(' : s ++ ")"
+ src/Hawk/Model/Criteria/Restriction.hs view
@@ -0,0 +1,248 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Restriction.hs 307 2009-05-06 10:29:12Z inf6254 $++   Restrictions for the criteria api
+-}
+-- ----------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+module Hawk.Model.Criteria.Restriction+  (+  -- * Data types and constructors+    Restriction+  , CompareValue+  , col+  , val+  , sqlVal+  -- * Restriction combinators+  , andExpr+  , (.&&.)+  , orExpr+  , (.||.)+  , allExpr+  , anyExpr+  , notExpr+  -- * SimpleRestriction constructors+  , nullExpr+  , notNullExpr+  , eqExpr+  , (.==.)  +  , neExpr+  , (./=.)+  , gtExpr+  , (.>.)+  , ltExpr+  , (.<.)+  , geExpr+  , (.>=.)+  , leExpr+  , (.<=.)+  , likeExpr+  , notlikeExpr+  , betweenExpr+  , inExpr+  ) where++import Hawk.Model.Criteria.Types+import Data.List (intercalate)+import Data.Convertible (Convertible)++-- | A Restriction+data Restriction = Simple SimpleRestriction+                 | NotExpr Restriction+                 | LogicExpr LogicOp [Restriction]++-- | The Operators And and Or+data LogicOp = And | Or++-- * Restriction combinators+-- | True if both Restrictions are true+andExpr :: Restriction -> Restriction -> Restriction+andExpr lhs rhs = allExpr [lhs, rhs]++(.&&.) :: Restriction -> Restriction -> Restriction+(.&&.) = andExpr++-- | True if one Restrictions is true+orExpr :: Restriction -> Restriction -> Restriction+orExpr lhs rhs = anyExpr [lhs, rhs]++(.||.) :: Restriction -> Restriction -> Restriction+(.||.) = orExpr++-- | True if all Restrictions are true+allExpr :: [Restriction] -> Restriction+allExpr = LogicExpr And++-- | True if one Restrictions is true+anyExpr :: [Restriction] -> Restriction+anyExpr = LogicExpr Or++-- | The not Operator+notExpr :: Restriction -> Restriction+notExpr = NotExpr++-- | Simple Restriction+data SimpleRestriction = UnExpr UnOp CompareValue+                       | BinExpr BinOp CompareValue CompareValue+                       | Between CompareValue CompareValue CompareValue+                       | In CompareValue [SqlValue]++data CompareValue = Col ColumnName+                  | Val SqlValue++-- | Construct a CompareValue from a Value in a Column+col :: ColumnName -> CompareValue+col = Col++-- | Construct a CompareValue from a Value+val :: Convertible a SqlValue => a -> CompareValue+val = Val . toSql++-- | Construct a CompareValue from a SqlValue+sqlVal :: SqlValue -> CompareValue+sqlVal = Val++-- | unary Operations+data UnOp = IsNull+          | IsNotNull++-- | binary Operations+data BinOp = Equal+           | NotEqual+           | GreaterThan+           | LessThan+           | GreaterThanOrEqual+           | LessThanOrEqual+           | Like+           | NotLike++--  SimpleRestriction constructors+-- | true if a column have a NULL Value+nullExpr :: CompareValue -> Restriction+nullExpr = Simple . UnExpr IsNull++-- | true if a column have a not a NULL Value+notNullExpr :: CompareValue -> Restriction+notNullExpr = Simple . UnExpr IsNotNull++-- | Compare the Value of two Columns. True if equal.+eqExpr :: CompareValue -> CompareValue -> Restriction+eqExpr l = Simple . BinExpr Equal l++(.==.) :: CompareValue -> CompareValue -> Restriction+(.==.) = eqExpr++-- | Compare the Value of two Columns. True if not equal.+neExpr :: CompareValue -> CompareValue -> Restriction+neExpr l = Simple . BinExpr NotEqual l++(./=.) :: CompareValue -> CompareValue -> Restriction+(./=.) = neExpr++-- | Compare the Value of two Columns. True if first value is greater then the second.+gtExpr :: CompareValue -> CompareValue -> Restriction+gtExpr l = Simple . BinExpr GreaterThan l++(.>.) :: CompareValue -> CompareValue -> Restriction+(.>.) = gtExpr++-- | Compare the Value of two Columns. True if first value is less then the second.+ltExpr :: CompareValue -> CompareValue -> Restriction+ltExpr l = Simple . BinExpr LessThan l++(.<.) :: CompareValue -> CompareValue -> Restriction+(.<.) = ltExpr++-- | Compare the Value of two Columns. True if first value is greater or equal then the second.+geExpr :: CompareValue -> CompareValue -> Restriction+geExpr l = Simple . BinExpr GreaterThanOrEqual l++(.>=.) :: CompareValue -> CompareValue -> Restriction+(.>=.) = geExpr++-- | Compare the Value of two Columns. True if first value is less or equal then the second.+leExpr :: CompareValue -> CompareValue -> Restriction+leExpr l = Simple . BinExpr LessThanOrEqual l++(.<=.) :: CompareValue -> CompareValue -> Restriction+(.<=.) = leExpr++-- | Test, if a column is like a String+likeExpr :: CompareValue -> CompareValue -> Restriction+likeExpr l = Simple . BinExpr Like l++-- | Test, if a column is not like a String+notlikeExpr :: CompareValue -> CompareValue -> Restriction+notlikeExpr l = Simple . BinExpr NotLike l++-- | Test, if the first value is between the second and third+betweenExpr :: CompareValue -> CompareValue -> CompareValue -> Restriction+betweenExpr v l = Simple . Between v l++-- | Test, if the first row is in the list of values.+inExpr :: Convertible a SqlValue => CompareValue -> [a] -> Restriction+inExpr l = Simple . In l . map toSql++instance ShowSql LogicOp where+  showSql And = " AND "+  showSql Or  = " OR "++instance ShowSql UnOp where+  showSql IsNull    = " IS NULL "+  showSql IsNotNull = " IS NOT NULL "++instance ShowSql BinOp where+  showSql Equal              = " == "+  showSql NotEqual           = " <> "+  showSql GreaterThan        = " > "+  showSql LessThan           = " < "+  showSql GreaterThanOrEqual = " >= "+  showSql LessThanOrEqual    = " <= "+  showSql Like               = " LIKE "+  showSql NotLike            = " NOT LIKE "++instance ShowSql CompareValue where+  showSql (Col c) = c+  showSql (Val v) = showSql v++instance ShowSql SimpleRestriction where+  showSql (UnExpr op c)+    = showSql op ++ paren (showSql c)+  showSql (BinExpr op c1 c2)+    = showSql c1 ++ showSql op ++ showSql c2+  showSql (Between c1 c2 c3)+    = showSql c1 ++ " BETWEEEN " ++ showSql c2 ++ " AND " ++ showSql c3+  showSql (In c vs)  = showSql c ++ " IN " ++ paren placeHolder+    where placeHolder = intercalate ", " $ map showSql vs++instance ShowSql Restriction where+  showSql (Simple s)        = showSql s+  showSql (NotExpr c)       = " NOT " ++ paren (showSql c)+  showSql (LogicExpr op cs)+    = intercalate (showSql op) $ map (paren . showSql) cs++instance GetValues CompareValue where+  getValues (Col _) = []+  getValues (Val v) = [v]++instance GetValues SimpleRestriction where+  getValues (UnExpr _ c)       = getValues c+  getValues (BinExpr _ c1 c2)  = concatMap getValues [c1,c2]+  getValues (Between c1 c2 c3) = concatMap getValues [c1,c2,c3]+  getValues (In c vs)          = getValues c ++ vs++instance GetValues Restriction where+  getValues (Simple s)       = getValues s+  getValues (NotExpr c)      = getValues c+  getValues (LogicExpr _ cs) = concatMap getValues cs++paren :: String -> String+paren s = '(' : s ++ ")"
+ src/Hawk/Model/Criteria/Types.hs view
@@ -0,0 +1,41 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Types.hs 307 2009-05-06 10:29:12Z inf6254 $++   Types for the criteria api
+-}
+-- ----------------------------------------------------------------------------+module Hawk.Model.Criteria.Types+    ( ShowSql (..)+    , GetValues (..)+    , toExprPair+    , SqlExprPair+    , module Hawk.Model.Types+    ) where++import Hawk.Model.Types++-- | A Pair from query string and sql values for HDBC+type SqlExprPair = (String, [SqlValue])++-- | SQL-Generating+class ShowSql p where+  showSql :: p -> String++-- | Getting out the values+class GetValues c where+  getValues :: c -> [SqlValue]++-- | Converts a ExprPair for HDBC+toExprPair :: (GetValues c, ShowSql c) => c -> SqlExprPair+toExprPair c = (showSql c, getValues c)++instance ShowSql SqlValue where+  showSql _ = "?"
+ src/Hawk/Model/CriteriaSelect.hs view
@@ -0,0 +1,12 @@+module Hawk.Model.CriteriaSelect where++import Hawk.Model.Criteria+import Hawk.Model.MonadDB+import Hawk.Model.Types++-- | Select a list of 'SqlValue's by a 'Query'+querySelect :: MonadDB m => Query -> m [[SqlValue]]+querySelect = uncurry sqlSelect . toExprPair++executeManipulation :: MonadDB m => Manipulation -> m Integer+executeManipulation = uncurry sqlExecute . toExprPair
+ src/Hawk/Model/Exception.hs view
@@ -0,0 +1,63 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+
+   Exceptions for the model
+-}
+-- --------------------------------------------------------------------------
+{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-}
+module Hawk.Model.Exception where
+
+import Data.Typeable
+import Control.Exception +  ( Exception(..)+  , SomeException+  )
+
+-- | Exception type for all 'Exception's which may occur in the model+data SomeModelException = forall a . (Exception a) => SomeModelException a+    deriving Typeable++instance Show SomeModelException where 
+  show (SomeModelException e) = show e++instance Exception SomeModelException+
+-- | Convert an 'Exception' to 'SomeModelException'+modelToException :: Exception e => e -> SomeException+modelToException = toException . SomeModelException+
+-- | Try to extract a 'SomeModelException'+modelFromException :: Exception e => SomeException -> (Maybe e)+modelFromException x = do+  SomeModelException e <- fromException x+  cast e+
+data RecordNotFound = RecordNotFound String+    deriving (Typeable, Show)++instance Exception RecordNotFound where+  toException = modelToException+  fromException = modelFromException++data SqlException = SqlException String+    deriving (Typeable, Show)++instance Exception SqlException where+  toException = modelToException
+  fromException = modelFromException++data UnmarshalException = UnmarshalException String+    deriving (Typeable, Show)++instance Exception UnmarshalException where+  toException = modelToException
+  fromException = modelFromException+
+ src/Hawk/Model/Model.hs view
@@ -0,0 +1,47 @@+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++-}+-- --------------------------------------------------------------------------+module Hawk.Model.Model where
+
+import Hawk.Model.Criteria (Criteria)
+import Hawk.Model.MonadDB (MonadDB)
+import Hawk.Model.Types (PrimaryKey)+import Hawk.Model.WithPrimaryKey+import Hawk.Model.Persistent+
+class WithPrimaryKey a => Model a where+  new              :: MonadDB m => m a+  count            :: MonadDB m => a -> Criteria -> m Integer+  select           :: MonadDB m => Criteria -> m [a]+  deleteByCriteria :: MonadDB m => a -> Criteria -> m Integer+  find             :: MonadDB m => [PrimaryKey] -> m [a]+  delete           :: MonadDB m => a -> m Bool
+  insert           :: MonadDB m => a -> m a
+  update           :: MonadDB m => a -> m a+  selectOne        :: MonadDB m => Criteria -> m a
+  selectMaybe      :: MonadDB m => Criteria -> m (Maybe a)+  findOne          :: MonadDB m => PrimaryKey -> m a+  findMaybe        :: MonadDB m => PrimaryKey -> m (Maybe a)++  count            =  countPersistents+  select           =  selectPersistents+  deleteByCriteria =  deleteByCriteriaInTransaction+  find             =  findByPKs+  delete           =  deleteInTransaction+  insert           =  insertInTransaction+  update           =  updateInTransaction+  selectOne        =  selectOnePersistent+  selectMaybe      =  selectMaybePersistent+  findOne          =  findOneByPK+  findMaybe        =  findMaybeByPK+
+ src/Hawk/Model/MonadDB.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TemplateHaskell #-}+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Bj�rn Peem�ller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++-}+-- --------------------------------------------------------------------------+module Hawk.Model.MonadDB+  ( MonadDB (..)+  , commit+  , rollback+  , inTransaction+  , sqlSelect+  , sqlExecute+  , sqlExecuteMany+  ) where++import Hawk.Model.Exception (SqlException (..))++import Prelude hiding (catch)++import Control.Monad.CatchIO+  ( MonadCatchIO+  , catch+  , onException+  )++import Control.Exception+  ( SomeException+  , throw+  )++import Control.Monad.Trans+  ( MonadIO+  , liftIO+  )++import qualified Database.HDBC as HDBC+  ( SqlValue+  , quickQuery'+  , execute+  , commit+  , ConnWrapper+  , rollback+  , Statement (executeMany)+  , IConnection (prepare)+  , catchSql+  )++import qualified System.Log.Logger as Logger+import System.Log.Logger.TH (deriveLoggers)+$(deriveLoggers "Logger" [Logger.DEBUG])++-- | Typeclass for operations on a database+class MonadCatchIO m => MonadDB m where+  getConnection :: m HDBC.ConnWrapper++-- | Handle a 'HDBC.SqlError' by catching it and throwing a 'SqlException'+handleSqlError :: IO a -> IO a+handleSqlError action = HDBC.catchSql action (throw . SqlException . show)++-- | Lift an 'IO'-Action using a 'HDBC.ConnWrapper' to a 'MonadDB' action.+--   'HDBC.SqlError's are catched and rethrown as 'SqlException's+liftDB :: MonadDB m => (HDBC.ConnWrapper -> IO a) -> m a+liftDB dbAction = getConnection >>= liftIO . handleSqlError . dbAction++-- | Commit the changes to the database+commit :: MonadDB m => m ()+commit = liftDB HDBC.commit++-- | Rollback the changes+rollback :: MonadDB m => m ()+rollback = liftDB HDBC.rollback++-- | Perform a non-lazy sql select+sqlSelect :: MonadDB m => String -> [HDBC.SqlValue] -> m [[HDBC.SqlValue]]+sqlSelect sql values = liftDB $ \conn -> do+  debugM $ "sqlSelect: sql=" ++ sql ++ ", values=" ++ show values+  res <- HDBC.quickQuery' conn sql values+  debugM $ "Returning: " ++ show res+  return res++-- | Execute a sql statement+sqlExecute :: MonadDB m => String -> [HDBC.SqlValue] -> m Integer+sqlExecute sql values  = liftDB $ \conn -> do+  debugM $ "sqlExecute: sql=" ++ sql ++ ", values=" ++ show values+  stat <- HDBC.prepare conn sql+  res <- HDBC.execute stat values+  -- TODO HDBC.run does not close connection correct every time, need to investigate+  debugM $ "Returning: " ++ show res+  return res++-- | Execute a sql statement many times using prepared statements+sqlExecuteMany :: MonadDB m => String -> [[HDBC.SqlValue]] -> m ()+sqlExecuteMany sql listOfValues = liftDB $ \conn -> do+  debugM $ "sqlExecuteMany: sql=" ++ sql ++ ", values=" ++ show listOfValues+  statement <- HDBC.prepare conn sql+  res <- HDBC.executeMany statement listOfValues+  debugM $ "Returning: " ++ show res+  return res++-- Execute a 'MonadDB' action in a transaction+inTransaction :: MonadDB m => m a -> m a+inTransaction action = onException committedAction $ rollback `catch` rollbackHandler+  where+    rollbackHandler :: MonadDB m => SomeException -> m ()+    rollbackHandler _ = return ()+    committedAction = do+                      res <- action+                      commit+                      return res
+ src/Hawk/Model/Persistent.hs view
@@ -0,0 +1,151 @@+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++-}+-- --------------------------------------------------------------------------++module Hawk.Model.Persistent+    ( -- Persistent and methods+      Persistent (..)+    , countPersistents+    , selectPersistents+    , selectOnePersistent+    , selectMaybePersistent+    , deletePersistentsByCriteria+    , deleteByCriteriaInTransaction+    , insertPersistent+    ) where++import Hawk.Model.Criteria+import Hawk.Model.CriteriaSelect+import Hawk.Model.Exception+import Hawk.Model.MonadDB+import Hawk.Model.Types+import Hawk.Model.Util++import Control.Exception (throw, onException)++import Control.Monad (liftM)+import Control.Monad.Trans (MonadIO, liftIO)+import Data.Char (toLower)++-- --------------------------------------------------------------------------+-- Persistent+-- --------------------------------------------------------------------------++-- | Typeclass for structures which are persistent in a database+--   Minimal implementation: 'persistentType', 'fromSqlList', 'toSqlAL'+class Persistent p where++  -- | The type of the persistent. The result must not use the value passed+  --   in such that+  --   persistentType undefined+  --   will give an appropriate result+  persistentType :: p -> String++  -- | Marshal a 'Persistent' as a list of 'SqlValue's+  toSqlList   :: p -> [SqlValue]+  toSqlList   = map snd . toSqlAL++  -- | Unmarshal a 'Persistent' from a list of 'SqlValue's+  fromSqlList :: [SqlValue] -> p+  fromSqlList list = result+    where+      result   = fromSqlAL $ zip columns list+      columns  = tableColumns (typeOf result)++  -- | Get the name of the associated database table, defaults to+  --  (++"s") map toLower $ persistentType p+  tableName :: p -> TableName+  tableName = (++"s") . map toLower . persistentType++  -- | Get the columns of the table+  tableColumns :: p -> [ColumnName]+  tableColumns = map fst . toSqlAL++  -- | Get the table columns and the values as an associated list+  toSqlAL :: p -> [(ColumnName, SqlValue)]+  toSqlAL p = zip (tableColumns p) (toSqlList p)++  -- | Unmarshal a persistent from an associated list containing the table+  --   columns and the 'SqlValue's.+  fromSqlAL :: [(ColumnName, SqlValue)] -> p+  fromSqlAL = fromSqlList . map snd+++-- --------------------------------------------------------------------------+-- Methods for Persistents+-- --------------------------------------------------------------------------++-- | Unmarshal a list of 'SqlValue's into a 'Persistent'.+--   Any 'Exception' is caught and rethrown as an 'UnmarshalException'.+unmarshal :: (MonadIO m, Persistent p) => [SqlValue] -> m p+unmarshal list = result+  where result = liftIO $ onException (return $ fromSqlList list)+                        $ throw (UnmarshalException msg)+        msg    = "Could not convert " ++ show list+              ++ " to Persistent " ++ persistentType (typeOfM result)++-- | Get the qualified table columns (table.column) of a 'Persistent'+qualifiedTableColumns :: Persistent p => p -> [String]+qualifiedTableColumns p = map prependTable $ tableColumns p+  where prependTable c  = tableName p ++ '.' : c++-- | Extend a 'Criteria' for a 'Persistent' to a 'Query'+toQuery :: Persistent p => p -> Criteria -> Query+toQuery p c = setProjection (map colP $ qualifiedTableColumns p)+            $ setCriteria c+            $ setTables [tableName p] +              newSelect++-- | Count the number of 'Persistent's satisfying the given 'Criteria'+countPersistents :: (MonadDB m, Persistent p) => p -> Criteria -> m Integer+countPersistents p c = liftM (fromSql . head . head)+                     $ querySelect+                     $ setProjection [rowCountP]+                     $ setCriteria c+                     $ setTables [tableName p]+                       newSelect++-- | Select a list of 'Persistent's by a 'Criteria'+selectPersistents :: (MonadDB m, Persistent p) => Criteria -> m [p]+selectPersistents c = result+  where result = querySelect (toQuery (typeOfM2 result) c) >>=+                 mapM unmarshal++-- | Select maybe one 'Persistent' by a 'Criteria'+selectMaybePersistent :: (MonadDB m, Persistent p) => Criteria -> m (Maybe p)+selectMaybePersistent = liftM safeHead . selectPersistents++-- | Select one 'Persistent' by a 'Criteria'. If no 'Persistent' satisfying+--   the 'Criteria' is found a 'RecordNotFound' exception is thrown.+--   If more then one record is found the first record will be returned.+selectOnePersistent :: (MonadDB m, Persistent p) => Criteria -> m p+selectOnePersistent c = liftM (unsafeHeadC c)+                      $ selectPersistents c++-- | Remove 'Persistent's by a 'Criteria'+deletePersistentsByCriteria :: (MonadDB m, Persistent p) => p -> Criteria -> m Integer+deletePersistentsByCriteria p c = executeManipulation +                                $ setManipulationCriteria c +                                $ newDelete +                                $ tableName p+++deleteByCriteriaInTransaction :: (MonadDB m, Persistent p) => p -> Criteria -> m Integer+deleteByCriteriaInTransaction p = inTransaction . deletePersistentsByCriteria p++-- |Insert a 'Persistent' into the database.+insertPersistent :: (MonadDB m, Persistent p) => p -> m Integer+insertPersistent p = executeManipulation+                   $ setValues (toSqlAL p)+                   $ newInsert +                   $ tableName p
+ src/Hawk/Model/Types.hs view
@@ -0,0 +1,41 @@+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   Some types used throughout the model+-}+-- --------------------------------------------------------------------------+module Hawk.Model.Types+  ( PrimaryKey+  , ForeignKey+  , TableName+  , ColumnName+  , SqlValue+  , fromSql+  , toSql+  ) where++import Database.HDBC +  ( SqlValue+  , fromSql+  , toSql+  )++-- | The type for primary keys+type PrimaryKey = Integer++-- | The type for foreign keys+type ForeignKey = Maybe PrimaryKey++-- | The name of a database table+type TableName  = String++-- | The name of a database column+type ColumnName = String
+ src/Hawk/Model/Updater.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances #-}+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++-}+-- --------------------------------------------------------------------------
+module Hawk.Model.Updater+  ( Params+  , UpdaterT+  , runUpdaterT+  , updateByParams+  , updateAndValidate+  , subParam+  , concatNameWith+  , Updateable (..)+  ) where
++import Control.Monad.Reader+import Control.Monad.Writer
+import qualified Data.Map as M (Map, lookup, member)+import Data.Maybe (listToMaybe)
+import Data.Time.Calendar+import Hawk.Model.Validator
+import Hawk.Model.MonadDB
+
+type Params = M.Map AttributeName String++newtype UpdaterT m a = UpdaterT { unwrap :: ReaderT Params (ValidatorT m) a }+        deriving (Functor, Monad, MonadIO, MonadWriter ValidationErrors, MonadReader Params)++instance MonadTrans UpdaterT where+  lift = UpdaterT . lift . lift+++runUpdaterT :: Monad m => UpdaterT m a -> Params -> ValidatorT m a+runUpdaterT = runReaderT . unwrap+++updateByParams :: (MonadDB m, Updateable u) => u -> String -> Params -> m (u, ValidationErrors)
+updateByParams updateable name = runValidatorT . runUpdaterT (updater updateable name)+
++updateAndValidate :: (MonadDB m, Updateable u, Validatable u) => u -> String -> Params -> m (u, ValidationErrors)+updateAndValidate updateable name params = runValidatorT $ do+  u' <- runUpdaterT (updater updateable name) params+  validator u'+  return u'++
+subParam :: String -> String -> String
+subParam = concatNameWith "."
+
++concatNameWith :: String -> String -> String -> String
+concatNameWith _   xs [] = xs
+concatNameWith _   [] ys = ys
+concatNameWith sep xs ys = xs ++ sep ++ ys
++    
+class Updateable u where
+  updater :: MonadDB m => u -> String -> UpdaterT m u+  updater u _ = return u+++instance Updateable Bool where+  updater value name = primitiveUpdate value name (maybeRead . mkBool) $ 
+                      "The attribute '" ++ name ++"' must be a Bool"+                      where mkBool :: String -> String+                            mkBool s | or [s == "on",s == "true"] = "True"+                                     | otherwise = "False"++instance Updateable String where
+  updater value name = primitiveUpdate value name Just $ 
+                      "The attribute '" ++ name ++"' must be a string"
++
+instance Updateable Int where
+  updater value name = primitiveUpdate value name maybeRead $ 
+                      "The attribute '" ++ name ++ "' must be an int"
++
+instance Updateable Integer where
+  updater value name = primitiveUpdate value name maybeRead $ 
+                      "The attribute '" ++ name ++ "' must be an integer"
+
+instance Updateable Double where
+  updater value name = primitiveUpdate value name maybeRead $ 
+                      "The attribute '" ++ name ++ "' must be a double"                
++
+instance Updateable Day where
+  updater value name = do
+    year  <- updater dy $ subParam name "year"
+    month <- updater dd $ subParam name "month"
+    day   <- updater dm $ subParam name "day"
+    return $ fromGregorian year month day
+    where (dy, dm, dd) = toGregorian value+++instance Updateable u => Updateable (Maybe u) where+  updater value name = do
+    params <- ask
+    if name `M.member` params
+      then do
+           (value', errs) <- listen $ updater undefined name+           if null errs+              then return $ Just value'+              else return value
+      else return value+++primitiveUpdate :: Monad m => a -> String -> (String -> Maybe a) -> String -> UpdaterT m a
+primitiveUpdate value name parser err = do
+  params <- ask
+  case M.lookup name params of 
+    Nothing    -> return value
+    Just param -> case parser param of
+      Nothing  -> addError name err >> return value
+      Just a   -> return a++maybeRead :: Read a => String -> Maybe a+maybeRead = listToMaybe . map fst . filter (null . snd) . reads
+ src/Hawk/Model/Util.hs view
@@ -0,0 +1,29 @@+module Hawk.Model.Util where++import Hawk.Model.Criteria+import Hawk.Model.Exception++import Control.Exception (throw)++safeHead :: [x] -> Maybe x+safeHead (x:_) = Just x+safeHead []    = Nothing++unsafeHeadC :: Criteria -> [x] -> x+unsafeHeadC = unsafeHeadMsg . show . toExprPair++unsafeHead :: [x] -> x+unsafeHead = unsafeHeadMsg ""++unsafeHeadMsg :: String -> [x] -> x+unsafeHeadMsg _   (x:_) = x+unsafeHeadMsg msg []    = throw $ RecordNotFound msg++typeOf :: p -> p+typeOf _ = undefined++typeOfM :: m p -> p+typeOfM _ = undefined++typeOfM2 :: m (n p) -> p+typeOfM2 _ = undefined
+ src/Hawk/Model/Validator.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-}+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++-}+-- --------------------------------------------------------------------------
+module Hawk.Model.Validator +  ( ValidationError+  , AttributeName+  , ValidationErrors+  , ValidatorT (ValidatorT)+  , Validatable (..)+  , execValidatorT+  , runValidatorT+  , addError+  , silent+  , check+  , validate+  , (>&>)+  , (>?>)+  , validateNull+  , validateNotNull+  , validateNothing+  , validateJust+  , validateNotEmpty+  , validateLength+  , validateFuture+  , validatePast+  , validateUniqueness+  ) where
+
+import Control.Monad.Writer
+import Data.Time+import Data.Maybe (isJust, isNothing, fromJust)+import Data.Convertible+import Hawk.Model.Criteria+import Hawk.Model.Types+import Hawk.Model.WithPrimaryKey+import Hawk.Model.CriteriaSelect+import Hawk.Model.Persistent+import Hawk.Model.MonadDB+
+type ValidationError  = String
+type AttributeName    = String
+type ValidationErrors = [(AttributeName, ValidationError)]
++newtype ValidatorT m a = ValidatorT { unwrap :: WriterT ValidationErrors m a }+        deriving (Functor, Monad, MonadIO, MonadTrans, MonadWriter ValidationErrors)++
+execValidatorT :: Monad m => ValidatorT m a -> m ValidationErrors
+execValidatorT = execWriterT . unwrap
++
+runValidatorT :: Monad m => ValidatorT m a -> m (a, ValidationErrors)
+runValidatorT = runWriterT . unwrap+++addError :: MonadWriter ValidationErrors m => AttributeName -> ValidationError -> m ()+addError src err = tell [(src, err)]+++silent :: MonadWriter ValidationErrors m => m a -> m a+silent = censor (const [])+++check :: Monad m => Bool -> ValidationError -> AttributeName -> ValidatorT m Bool+check b err src = unless b (addError src err) >> return b+++validate :: Monad m => (a -> Bool) -> ValidationError -> AttributeName -> a -> ValidatorT m Bool
+validate p err src value = check (p value) err src++
+(>&>) :: Monad m =>+     (AttributeName -> a -> ValidatorT m Bool) ->+     (AttributeName -> a -> ValidatorT m Bool) ->+      AttributeName -> a -> ValidatorT m Bool
+(f >&> g) name value = do+  res  <- f name value+  res2 <- g name value+  return $ res && res2
+++(>?>) :: Monad m =>+     (AttributeName -> a -> ValidatorT m Bool) ->+     (AttributeName -> a -> ValidatorT m Bool) ->+      AttributeName -> a -> ValidatorT m Bool
+(f >?> g) name value = do
+  res <- f name value
+  if res
+    then g name value
+    else return False
++
+validateNull :: (Monad m) => AttributeName -> [a] -> ValidatorT m Bool+validateNull = validate null "must be null"+++validateNotNull :: (Monad m) => AttributeName -> [a] -> ValidatorT m Bool
+validateNotNull = validate (not . null) "must not be null"+++validateNothing :: Monad m => AttributeName -> Maybe a -> ValidatorT m Bool+validateNothing = validate isNothing "must be nothing"+++validateJust :: Monad m => AttributeName -> Maybe a -> ValidatorT m Bool+validateJust = validate isJust "must be just"+++validateNotEmpty :: Monad m => AttributeName -> Maybe [a] -> ValidatorT m Bool+validateNotEmpty name value = do+  res <- validateJust name value+  if res +    then validateNotNull name $ fromJust value+    else return False+++validateLength :: Monad m => Int -> Int -> AttributeName -> [a] -> ValidatorT m Bool+validateLength minLen maxLen name value = check (minLen <= len && len <= maxLen) err name+  where+    len = length value+    err = "length must be between " ++ show minLen ++ " and " ++ show maxLen+++validateFuture :: MonadIO m => AttributeName -> UTCTime -> ValidatorT m Bool
+validateFuture time src = do
+  now <- liftIO getCurrentTime
+  validate (> now) "must be in the future" time src
+++validatePast :: MonadIO m => AttributeName -> UTCTime -> ValidatorT m Bool
+validatePast time src = do
+  now <- liftIO getCurrentTime
+  validate (< now) "must be in the past" time src
++
+validateUniqueness :: (WithPrimaryKey p, MonadDB m, Convertible a SqlValue)+                   => [(ColumnName, SqlValue)]+                   -> (p -> a)+                   -> AttributeName+                   -> p+                   -> ValidatorT m Bool+validateUniqueness scope getter src p = do+  ids <- lift $ querySelect query+  check (null ids || ids == [[pkValue]]) "must be unique" src+  where+    query                = setProjection [colP pkCol]
+                         $ modifyCriteria (setRestriction rest)+                         $ setTables [tableName p]+                           newSelect+    rest                 = allExpr +                         $ map toRestriction +                         $ (src, toSql $ getter p) : scope+    toRestriction (c, v) = eqExpr (col c) (sqlVal v)+    pkCol                = pkColumn p+    pkValue              = toSql $ primaryKey p+++class Validatable v where
+  validator :: MonadDB m => v -> ValidatorT m ()+  validator _ = return ()+
+ src/Hawk/Model/WithForeignKey.hs view
@@ -0,0 +1,172 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $
+
+-}
+-- --------------------------------------------------------------------------++{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses #-}++module Hawk.Model.WithForeignKey
+    ( ForeignKeyRelationship (..)+    , getMaybeReferenced+    , getOneReferenced+    , setReferenced+    , removeReferenced+    , getReferencings+    , getMaybeReferencing+    , getOneReferencing+    , addReferencing+    , removeReferencing+    , replaceReferencing+    ) where
+
+import Hawk.Model.Criteria+import Hawk.Model.Exception+import Hawk.Model.MonadDB
+import Hawk.Model.Persistent+import Hawk.Model.WithPrimaryKey
+import Hawk.Model.Types+import Hawk.Model.Util++import Control.Monad (liftM)++import Control.Exception (throw)++++-- | Typeclass for ForeignKey relationships+{-+class (Persistent self, WithPrimaryKey other) =>+      WithForeignKey self relationshipName other |+      relationshipName -> self other where+-}+class (Persistent (Referencing r), WithPrimaryKey (Referenced r)) =>+      ForeignKeyRelationship r where+  type Referencing r :: *+  type Referenced  r :: *++  relationshipName :: r -> String++  -- | Get the 'ColumnName' containing the 'ForeignKey'+  fkColumn      :: r -> ColumnName++  -- | Get the value of the 'ForeignKey'+  foreignKey    :: r -> Referencing r -> ForeignKey++  -- | Set the value of the 'ForeignKey'+  setForeignKey :: r -> Referencing r -> ForeignKey -> Referencing r
+
+  
+-- --------------------------------------------------------------------------
+-- Functions derived from WithForeignKey
+-- --------------------------------------------------------------------------
+getMaybeReferenced :: (MonadDB m, ForeignKeyRelationship r)
+                   => r
+                   -> Referencing r
+                   -> m (Maybe (Referenced r))
+getMaybeReferenced rel referencing+  = case foreignKey rel referencing of
+      Nothing  -> return Nothing
+      Just key -> findMaybeByPK key+++getOneReferenced :: (MonadDB m, ForeignKeyRelationship r)
+              => r
+              -> Referencing r
+              -> m (Referenced r)
+getOneReferenced rel referencing+  = case foreignKey rel referencing of
+      Nothing  -> throw $ RecordNotFound msg
+      Just key -> findOneByPK key+  where msg =  "Persistent '" ++ persistentType referencing+            ++ "' has no foreign key for relationship '"+            ++ relationshipName rel ++ "'"++
+setReferenced :: (MonadDB m, ForeignKeyRelationship r)
+              => r 
+              -> Referencing r
+              -> Maybe (Referenced r)
+              -> m (Referencing r)
+setReferenced rel referencing+  = return . setForeignKey rel referencing . fmap primaryKey+++removeReferenced :: (MonadDB m, ForeignKeyRelationship r)
+                 => r 
+                 -> Referencing r
+                 -> Referenced r
+                 -> m (Referencing r)+removeReferenced rel referencing referenced
+  = if Just (primaryKey referenced) == foreignKey rel referencing
+       then setReferenced rel referencing Nothing
+       else return referencing+++getReferencings :: (MonadDB m, ForeignKeyRelationship r)+                => r+                -> Referenced r+                -> m [Referencing r]+getReferencings rel referenced+  = selectPersistents $ restrictionCriteria restr+  where restr = eqExpr (col $ fkColumn rel) (val $ primaryKey referenced)+++getMaybeReferencing :: (MonadDB m, ForeignKeyRelationship r)+                    => r+                    -> Referenced r+                    -> m (Maybe (Referencing r))+getMaybeReferencing rel = liftM safeHead . getReferencings rel+++getOneReferencing :: (MonadDB m, ForeignKeyRelationship r)
+                  => r
+                  -> Referenced r
+                  -> m (Referencing r)+getOneReferencing rel parent+  = liftM (unsafeHeadMsg msg) $ getReferencings rel parent+  where msg =  "Persistent '" ++ persistentType parent+            ++ "' with primary key '" ++ show (primaryKey parent)+            ++ "' has no child in the foreign key relationship '"+            ++ show (relationshipName rel) ++ "'"+++addReferencing :: (MonadDB m, ForeignKeyRelationship r)+               => r+               -> Referenced r+               -> Referencing r+               -> m (Referencing r)+addReferencing rel referenced referencing+  = setReferenced rel referencing (Just referenced)+++removeReferencing :: (MonadDB m, ForeignKeyRelationship r)+                  => r+                  -> Referenced r+                  -> Referencing r+                  -> m (Referencing r)+removeReferencing = flip . removeReferenced+++replaceReferencing :: (MonadDB m, ForeignKeyRelationship r)+                   => r+                   -> Referenced r+                   -> Maybe (Referencing r)+                   -> m (Maybe (Referencing r), Maybe (Referencing r))+replaceReferencing rel referenced newReferencing = do+  oldReferencing  <- getMaybeReferencing rel referenced+  oldReferencing' <- case oldReferencing of+                       Nothing -> return Nothing+                       Just o  -> liftM Just $ setReferenced rel o Nothing+  newReferencing' <- case newReferencing of+                       Nothing -> return Nothing+                       Just n  -> liftM Just $ setReferenced rel n (Just referenced)+  return (oldReferencing', newReferencing')
+ src/Hawk/Model/WithPrimaryKey.hs view
@@ -0,0 +1,105 @@+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++-}+-- --------------------------------------------------------------------------+module Hawk.Model.WithPrimaryKey+  ( WithPrimaryKey (..)+  , findByPKs+  , findOneByPK+  , findMaybeByPK+  , insertByPK+  , insertInTransaction+  , updateByPK+  , updateInTransaction+  , deleteByPK+  , deleteInTransaction+  ) where++import Hawk.Model.Criteria+import Hawk.Model.CriteriaSelect+import Hawk.Model.MonadDB+import Hawk.Model.Persistent+import Hawk.Model.Types+import Hawk.Model.Util++import Control.Monad (liftM)++-- | Typeclass for persistent structures with a 'PrimaryKey'+class Persistent p => WithPrimaryKey p where++  -- | Get the column containing the 'PrimaryKey'+  pkColumn       :: p -> ColumnName++  -- | Get the 'PrimaryKey'+  primaryKey     :: p -> PrimaryKey++  -- | Set the 'PrimaryKey'+  setPrimaryKey  :: PrimaryKey -> p -> p+++-- --------------------------------------------------------------------------+-- Methods for WithPrimaryKey+-- --------------------------------------------------------------------------++-- | Get the values of a 'WithPrimaryKey' without the 'PrimaryKey'+nonPKValues :: (WithPrimaryKey p) => p -> [(ColumnName, SqlValue)]+nonPKValues p = filter ((/= pkColumn p) . fst) $ toSqlAL p++-- | Create a 'Criteria' for the 'PrimaryKey's in the list+idCriteria :: (WithPrimaryKey p) => p -> [PrimaryKey] -> Criteria+idCriteria p ks = setRestriction (inExpr (col $ pkColumn p) ks) newCriteria++-- TODO documentation+findByPKs :: (MonadDB m, WithPrimaryKey p) => [PrimaryKey] -> m [p]+findByPKs ks = result+  where result = selectPersistents $ idCriteria (typeOfM2 result) ks++-- TODO documentation+findOneByPK :: (MonadDB m, WithPrimaryKey p) => PrimaryKey -> m p+findOneByPK k = result+  where result  = selectOnePersistent $ idCriteria (typeOfM result) [k]++-- TODO documentation+findMaybeByPK :: (MonadDB m, WithPrimaryKey p) => PrimaryKey -> m (Maybe p)+findMaybeByPK k = result+  where result  = selectMaybePersistent $ idCriteria (typeOfM2 result) [k]++-- |Insert a 'WithPrimaryKey' into the database+--  The result contains the original 'WithPrimaryKey' with its 'PrimaryKey'+--  updated+insertByPK :: (MonadDB m, WithPrimaryKey p) => p -> m p+insertByPK p = do+  _ <- executeManipulation $ setValues (nonPKValues p) $ newInsert $ tableName p+  newId <- sqlSelect "SELECT last_insert_rowid()" []+  return $ setPrimaryKey (fromSql $ head $ head newId) p++insertInTransaction :: (MonadDB m, WithPrimaryKey p) => p -> m p+insertInTransaction = inTransaction . insertByPK++updateByPK :: (MonadDB m, WithPrimaryKey p) => p -> m Bool+updateByPK p = liftM (==1)+             $ executeManipulation+             $ setManipulationCriteria (idCriteria p [primaryKey p])+             $ setSet (nonPKValues p)+             $ newUpdate+             $ tableName p++updateInTransaction :: (MonadDB m, WithPrimaryKey p) => p -> m p+updateInTransaction p = inTransaction $ updateByPK p >> return p++deleteByPK :: (MonadDB m, WithPrimaryKey p) => p -> m Bool+deleteByPK p = liftM (==1)+             $ deletePersistentsByCriteria p +             $ idCriteria p [primaryKey p]++deleteInTransaction :: (MonadDB m, WithPrimaryKey p) => p -> m Bool+deleteInTransaction = inTransaction . deleteByPK
+ src/Hawk/View.hs view
@@ -0,0 +1,19 @@+module Hawk.View+  ( -- | View Types+    module Hawk.View.EmptyView+  , module Hawk.View.JsonView+  , module Hawk.View.TextView+  , module Hawk.View.TemplateView+    -- | Helper to create Html with 'HXT'+  , module Hawk.View.Template.HtmlHelper+    -- | 'TH' to define output Data Types+  , module Hawk.View.Template.DataType+  ) where++import Hawk.View.EmptyView+import Hawk.View.JsonView+import Hawk.View.TextView+import Hawk.View.TemplateView hiding (XmlTree) -- is imported by HtmlHelper from HXT+import Hawk.View.Template.HtmlHelper+import Hawk.View.Template.DataType+
+ src/Hawk/View/EmptyView.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TypeFamilies #-}+module Hawk.View.EmptyView+  ( EmptyView+  , emptyView+  ) where++import Data.ByteString.Lazy ( empty )+import Hawk.Controller.Types ( View (..) )++data EmptyView a = EmptyView++emptyView :: EmptyView a+emptyView = EmptyView++{-+instance View EmptyView a where+  render _ _ = return empty+-}++instance View (EmptyView a) where+  type Target (EmptyView a) = a+  render _ _ = return empty
+ src/Hawk/View/JsonView.hs view
@@ -0,0 +1,110 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2010 Alexander Treptow
+   License     :  BSD3
+
+   Maintainer  :  {inf6866}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  
+
+   
+-}
+-- --------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+module Hawk.View.JsonView+  ( JsonView (..)+  , jsonView+  , jsonDecode+  , jsonEncode+  , JSON (..)+  , jObject+  , jArray+  , jString+  , jXml+  , jNumber+  , jInt+  , jInteger+  , jDouble+  , jFloat+  , jBool+  , jNull+  ) where++import Hawk.Controller.Types+  ( StateController+  , View (..)+  )+import Hawk.View.Template.HtmlHelper (XmlTrees)++--import Data.ByteString.UTF8 ( ByteString )+import Data.ByteString.Lazy.Internal ( ByteString )+import qualified Data.ByteString.UTF8 as U+import Data.Ratio+import Data.Trie++import Control.Monad (liftM)++import Text.JSONb.Simple ( JSON (..) )+import Text.JSONb.Decode ( decode )+import Text.JSONb.Encode ( encode, Style (..) )++import Text.XML.HXT.DOM.ShowXml++data JsonView a = JsonView {toJson :: a -> StateController JSON}++jsonView :: (a -> StateController JSON) -> JsonView a+jsonView = JsonView++instance View (JsonView a) where+  type Target (JsonView a) = a+  -- :: a -> Target a -> StateController ByteString+  render jv = liftM jsonEncode . toJson jv++jsonEncode :: JSON -> ByteString+jsonEncode = encode Compact++--decode :: ByteString -> Either (ParseError, ByteString) JSON+jsonDecode :: ByteString -> (String, JSON)+jsonDecode s = either l r $ decode s+  where l = (\(e,_) -> (e, Null))+        r = (\j -> ("", j))++jObject :: [(String, JSON)] -> JSON+jObject [] = Object empty+jObject l = Object $ fromList $ ol l+  where +  ol :: [(String, JSON)] -> [(KeyString, JSON)]+  ol [] = []+  ol ((s,j):xs) = (U.fromString s, j) : (ol xs)++jArray :: [JSON] -> JSON+jArray = Array++jString :: String -> JSON+jString s = String $ U.fromString s++jXml :: XmlTrees -> JSON+jXml x = jString $ xshow x++jNumber :: Rational -> JSON+jNumber = Number++jInt :: Int -> JSON+jInt i = jNumber $ (toInteger i) % 1++jInteger :: Integer -> JSON+jInteger i = jNumber (i % 1)++jDouble :: Double -> JSON+jDouble d = jNumber $ approxRational d 0.000001++jFloat :: Float -> JSON+jFloat f = jNumber $ approxRational f 0.000001++jBool :: Bool -> JSON+jBool = Boolean++jNull :: JSON+jNull = Null
+ src/Hawk/View/Template/DataType.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE Arrows, NoMonomorphismRestriction, TemplateHaskell #-}+-- --------------------------------------------------------------------------+{- |+   Module      :  $Header$+   Copyright   :  Copyright (C) 2009-2010 Björn Peemöller, Stefan Roggensack+   License     :  BSD3++   Maintainer  :  {inf6254, inf6509}fh-wedel.de+   Stability   :  experimental+   Portability :  portable++-}+-- --------------------------------------------------------------------------+module Hawk.View.Template.DataType+    ( viewDataType+    , viewDataTypeWithPrefix+    , Bindable(..)+    , showData)+    where++import Text.XML.HXT.Arrow hiding (mkName)+import Language.Haskell.TH+import Hawk.Controller.Util.Text (firstLower, firstUpper, toCamelCase)+import Hawk.View.Template.Interpreter+import Hawk.View.Template.ToXhtml++import Control.Monad ((>=>), liftM, filterM)+import Data.Char (isAlpha)+import Text.Regex.Posix (getAllTextSubmatches, (=~))+import Data.EitherMapTree++-- | A Class which allow to write a custom function to create a BindTree+class Bindable a where+    bindable :: a -> BindTree++-- | The path of the templates+baseDir :: String+baseDir = "App/template/" --TODO make use of config++-- | Check if the node is for Hawk+isHawk :: (ArrowXml a) => a XmlTree XmlTree+isHawk = hasNamePrefix hawkPrefix -- hasNamespaceUri "http://fh-wedel.de/hawk"++-- | Calculate the function name of bind function for this File+functionName :: File -> Name+functionName = mkName . (++) "bind" . toTypeName . name2++-- | Calculate the typeNam name of bind function for this File+typeName :: File -> Name+typeName = mkName . toTypeName . name2++-- | Convert a String to type name (all . are converted to CamelCase and the first char is convertet+-- to upper)+toTypeName :: String -> String+toTypeName = firstUpper . toCamelCase '.'++-- | Calculate the Type of field of the data+dataConstructor :: Bind -> TypeQ+dataConstructor (Bind _ _ Nothing _) = [t| [XmlTree] |]+dataConstructor (Bind _ _ (Just t) _) = conT t+dataConstructor (Embed _ m n _) = appT listT $ conT $ mkName $ (++) m $ firstUpper $ toCamelCase '.' n++-- | Calculate the Name of field of the data+constructorName :: Bind -> Name+constructorName (Bind p n _ _) = mkName $ firstLower (p ++ firstUpper (toCamelCase '.' n))+constructorName (Embed p m n _) = mkName $ firstLower (p ++ firstUpper (toCamelCase '.' (m ++ firstUpper n)))++-- | Calculate the Name from a String+toTypeContructor :: String -> Name+toTypeContructor = mkName . firstLower . toCamelCase '.'++-- | Drop all not alpha (isAlpha) chars of a String+firstToAlpha :: String -> String+firstToAlpha = dropWhile $ not . isAlpha++-- | A data structure that represenst a Bind or a embed Tag+data Bind = Bind {+    prefix :: String,+    name :: String, -- ^ the name+    typeInfo :: Maybe Name, -- ^ the type info+    formatFunc :: Maybe Name -- ^ the format function+    } |+    Embed {+    prefix :: String,+    moduleName :: String,+    name :: String,+    what :: String+    }+    deriving (Show)++-- | A data structure that represents a File with a list of binds and a name+data File = File {+    name2 :: String,+    binds :: [Bind]+    }+    deriving (Show)++-- | Create a embed Data from the strings of a embed tag+embed :: String -- ^ the Prefix+    -> String -- ^ the current Module+    -> String -- ^ the value of the what attribut+    -> Bind+embed p m w = Embed p m' n w+    where+    (m', n) = parseWhat m w++-- | Parse the what attribut of a embed tag+parseWhat :: String -> String -> (String, String)+parseWhat modu s = if null withMod then (modu, fileWithout) else (withMod !! 1, withMod !! 2)+    where+    withMod = getAllTextSubmatches $ s =~ "../(.*)/(.*).xhtml" :: [String]+    [_, fileWithout] = getAllTextSubmatches $ s =~ "(.*).xhtml"++-- | Create the Bin data+bindAttr :: String -- ^ The Prefix+    -> String -- ^ The Name+    -> String -- ^ The value of the type attribute+    -> String -- ^ The value of the format attribute+    -> Bind+bindAttr p nameAtr typeAtr format = Bind p nameAtr+    (toMaybe' typeAtr >>= Just . mkName . firstUpper)+    (toMaybe' format >>= Just . mkName)++-- | Creates a DataType for a Xhtml Template+viewDataType :: String -- ^ The module of the Template+    -> String -- ^ The Name of the Template without the file extension+    -> Q [Dec]+viewDataType = viewDataTypeWithPrefix ""++-- | Creates a DataType for a Xhtml Template with a Prefix. This could be used to prevent+-- name clashes+viewDataTypeWithPrefix :: String -> String -> String -> Q [Dec]+viewDataTypeWithPrefix pre modu = runIO . readTree pre modu >=> (sequence . buildPair)++-- | Create the data and the instacne declaration for a File+buildPair :: File -> [DecQ]+buildPair f = [buildInstance f, buildData f]++-- | create the Data declaration for a File+buildData :: File -> DecQ+buildData s@(File _ l) =+    makeData name' [(name', map (constructorName &&& dataConstructor) l)]+    where+        name' = typeName s++-- | Create the instance declaration for the Bindable class+buildInstance :: File -> DecQ+buildInstance f = do+    x <- newName "x"+    instanceD (cxt [])+        (appT+            (conT ''Bindable)+            (conT $ typeName f))+        [funD 'bindable+            [clause+                [varP x]+                (normalB (appE+                    (varE 'Data.EitherMapTree.fromList)+                    (listE (map (makeTerm x) (binds f)))))+                []+             ]+         ]++-- | Create the Term for converting the Data into the BindTree+makeTerm :: Name -> Bind -> ExpQ+makeTerm x b@(Bind _ n _ f) = singleTerm f+    where+        singleTerm Nothing = [| ($(litE $ stringL n), Right $ toXhtml ($(varE $ constructorName b) $(varE x))) |]+        -- Use $(litE $ stringL n) insteed of n for readablety in pprint output+        singleTerm (Just f') = [| ($(litE $ stringL n), Right $ $(varE f') ($(varE $ constructorName b) $(varE x))) |]+makeTerm x e@(Embed _ m n w) = deeper+    where+        deeper = [| ($(litE $ stringL w), Left $+            map $(varE 'bindable)+                $(appE+                    (varE $ constructorName e)+                    (varE x))) |]++-- | Create a Data declaration+makeData :: Name                       -- ^ the name of the new Data+          -> [(Name, [(Name, TypeQ)])] -- ^ the Constructors and the containing names and types+          -> DecQ                      -- ^ the data type+makeData name' members = dataD (cxt []) name' [] (map construct members) [] -- derivingShow+    where+        cons = map (\(x,y) -> varStrictType x (strictType notStrict y))+        construct (n, m) = recC n (cons m)++-- | Convert a list maybe list which is not empty. So [] gives Nothing and [a] gives Just [a]+toMaybe' :: [a] -> Maybe [a]+toMaybe' x = toMaybe (not $ null x) x++-- * Build Tree++-- | Read a File and return the tree of a relevant Tags+readTree :: String -> String -> String -> IO File+readTree pre modu name' = liftM head (+    runX $+        constA (baseDir ++ modu ++ "/" ++ name' ++ ".xhtml")+        >>> prepareDoc' >>> makeTree pre modu name') >>= filterEmbed++-- | filter the embed for empty files. If the embeded file contain no defniton of embed or bind+-- it will remved from the file.+filterEmbed :: File -> IO File+filterEmbed s@(File _ b) = do+    b' <- filterM isNotEmtpy b+    return s {binds = b'}++-- | Check if the Embeded file contain a embed or bind tag. For a Bind alway True is returned.+isNotEmtpy :: Bind -> IO Bool+isNotEmtpy (Embed _ m n _) =+  liftM (not . null) $ runX $+    constA (baseDir ++ m ++ "/" ++ n ++ ".xhtml")+    >>> prepareDoc'+    >>> deep+        (isHawk >>>+            (hasLocalPart "bind" `orElse` hasLocalPart "embed"))+isNotEmtpy (Bind _ _ _ _) = return True+++-- | Arrow for converting the XmlTree into the File data+makeTree :: (ArrowXml a, ArrowChoice a) => String -> String -> String -> a XmlTree File+makeTree pre modu name' = listA (makeHawk pre modu) >>> arr (File (modu ++ firstUpper name'))++-- | Arrow that filter the hawk Tags bind and embed and put them into buildFile+makeHawk :: (ArrowXml a, ArrowChoice a) => String -> String -> a XmlTree Bind+makeHawk pre modu = proc s -> do+    c <- getChildren -< s+    b <- deep (isHawk >>> (hasLocalPart "bind" `orElse` hasLocalPart "embed")) -< c+    buildFile pre modu -< b++-- | run buildBind or buildEmbed for the Xml tag+buildFile :: (ArrowXml a) => String -> String -> a XmlTree Bind+buildFile pre modu = choiceA+    [ hasLocalPart "bind"  :-> buildBind pre+    , hasLocalPart "embed" :-> buildEmbed pre modu]++-- | Convert a hawk bind tag into the Bind Data+buildBind :: (ArrowXml a) => String -> a XmlTree Bind+buildBind pre = (getAttrValue0 "name"+        &&& getAttrValue "type")+        &&& getAttrValue "format" >>> arr (uncurry (uncurry (bindAttr pre)))++-- | Convert a hawk embed tag into the Embed Data+buildEmbed :: (ArrowXml a) => String -> String -> a XmlTree Bind+buildEmbed pre modu = getAttrValue0 "what" >>> arr (embed pre modu)++-- * Testing Helpe++-- | Function to show a DataType+showData :: String -- ^ The Prefix+    -> String -- ^ The module name+    -> String -- ^ The template name+    -> IO ()+showData p m n = runQ (viewDataTypeWithPrefix p m n) >>= putStrLn . pprint
+ src/Hawk/View/Template/Helper/DateHelper.hs view
@@ -0,0 +1,122 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   Helper functions for creating xml tags for date and time input.
+-}
+-- --------------------------------------------------------------------------+module Hawk.View.Template.Helper.DateHelper+  ( -- date selection+    selectYear+  , selectYearS+  , selectMonth+  , monthNumbers+  , monthNames+  , selectDay+  , selectDate++  -- time selection+  , selectHour+  , selectMinute+  , selectSecond+  , selectTime++  -- datetime selection+  , selectUTCDateTime+  , selectLocalDateTime+  ) where++import Hawk.View.Template.Helper.TagHelper+import Hawk.View.Template.Helper.FormHelper+import Data.Time++-- --------------------------------------------------------------------------+-- Date Selection+-- --------------------------------------------------------------------------++-- | Create a select combobox for year selection+selectYear :: String -> Integer -> Integer -> Integer -> Attributes -> XmlTree+selectYear name current start end attrs = select name opts attrs+  where+    years = if start <= end then [start..end] else reverse [end..start]+    opts  = optionsWithSelected show show current years++selectYearS :: String -> Integer -> Attributes -> XmlTree+selectYearS name current = selectYear name current (current - 5) (current + 5)++selectMonth ::String -> Int -> (Int -> String) -> Attributes -> XmlTree+selectMonth name current format attrs = select name opts attrs+  where opts = optionsWithSelected show format current [1..12]++monthNumbers :: Int -> String+monthNumbers = show++monthNames :: Int -> String+monthNames i = [ "January"  , "February", "March"   , "April"+               , "May"      , "June"    , "July"    , "August"+               , "September", "October" , "November", "December"+               ] !! (i-1)++selectDay :: String -> Int -> Attributes -> XmlTree+selectDay name current attrs = select name opts attrs+  where opts = optionsWithSelected show show current [1..31]++selectDate :: String -> Day -> (Int -> String) -> Attributes -> XmlTrees+selectDate name day f attrs+  = [ selectDay   (name ++ ".day"  ) d   attrs+    , selectMonth (name ++ ".month") m f attrs+    , selectYearS (name ++ ".year" ) y   attrs+    ]+  where (y,m,d) = toGregorian day++-- --------------------------------------------------------------------------+-- Time Selection+-- --------------------------------------------------------------------------++selectHour :: String -> Int -> Attributes -> XmlTree+selectHour name currentHour attrs = select name opts attrs+  where opts = optionsWithSelected leadingZero leadingZero currentHour [0..23]+++selectMinute :: String -> Int -> Attributes -> XmlTree+selectMinute name currentMinute attrs = select name opts attrs+  where opts = optionsWithSelected leadingZero leadingZero currentMinute [0..59]+++selectSecond :: String -> Int -> Attributes -> XmlTree+selectSecond name currentSecond attrs = select name opts attrs+  where opts = optionsWithSelected leadingZero leadingZero currentSecond [0..59]++leadingZero :: Int -> String+leadingZero n = if n <= 9 then '0':show n else show n+++selectTime :: String -> TimeOfDay -> Attributes -> XmlTrees+selectTime name now attrs+  = [ selectHour   (name ++ ".hour"  ) h attrs+    , selectMinute (name ++ ".minute")   m attrs+    , selectSecond (name ++ ".second") (truncate s) attrs+    ]+  where (TimeOfDay h m s) = now+++selectUTCDateTime :: String -> String -> UTCTime -> (Int -> String) -> Attributes -> XmlTrees+selectUTCDateTime name sep now monthFormat attrs+  =  selectDate name (utctDay now) monthFormat attrs+  ++ [mkText sep]+  ++ selectTime name (timeToTimeOfDay $ utctDayTime now) attrs+++selectLocalDateTime :: String -> String -> LocalTime -> (Int -> String) -> Attributes -> XmlTrees+selectLocalDateTime name sep now monthFormat attrs+  =  selectDate name (localDay now) monthFormat attrs+  ++ [mkText sep]+  ++ selectTime name (localTimeOfDay now) attrs+
+ src/Hawk/View/Template/Helper/FormHelper.hs view
@@ -0,0 +1,227 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   Helper functions for creating xhtml form elements
+-}
+-- --------------------------------------------------------------------------+module Hawk.View.Template.Helper.FormHelper+  ( -- Selection+    select+  , multiselect+  , options+  , optionsWithSelected+  , optionsFromString+  , checkbox+  , radio++    -- Input+  , textfield+  , textarea+  , password+  , hidden+  , submit+  , submitWithName+  , fileupload++    -- other+  , form+  , slabel+  , label+  , textlink+  , link+  , linkA+  , image+  ) where++import Hawk.View.Template.Helper.TagHelper++-- --------------------------------------------------------------------------+-- Selection: combobox, checkbox, radio button+-- --------------------------------------------------------------------------++-- | Create a dropdown selection box+select :: String     -- ^ name of the field+       -> XmlTrees   -- ^ options to select+       -> Attributes -- ^ additional 'Attributes' for the select tag+       -> XmlTree+select name opts attrs = contentTag "select" attrs' opts+  where attrs' = attrs ++ [("id", name), ("name", name)]+++-- | Create a multiselect dropdown box+multiselect  :: String     -- ^ name of the field+             -> XmlTrees   -- ^ options to select+             -> Attributes -- ^ additional 'Attributes' for the select tag+             -> XmlTree+multiselect name opts attrs = select name opts attrs'+  where attrs' = ("multiple", "multiple") : attrs+++-- | Create a list of options+options :: (a -> String)+        -> (a -> String)+        -> [a]+        -> XmlTrees+options showVal showOpt+  = map (\o -> contentTag "option" (attrs o) [mkText $ showOpt o])+  where attrs o = [("value", showVal o)]++-- | Create a list of options for selection+optionsWithSelected :: (Eq a, Show a)+        => (a -> String)  -- ^ function for printing the value+        -> (a -> String)  -- ^ function for printing the label for choosing+        -> a              -- ^ pre-selected value+        -> [a]            -- ^ the value list+        -> XmlTrees+optionsWithSelected showVal showOpt s+  = map (\o -> contentTag "option" (attrs o) [mkText $ showOpt o])+  where+    attrs o    = ("value", showVal o) : selected o+    selected o = [("selected", "selected") | o == s]+++-- | Create an option list from a list of 'String' pairs (key, value)+optionsFromString :: [(String, String)] -- ^ the options+                  -> XmlTrees+optionsFromString = map $ \(v, s) -> contentTag "option" [("value", v)] [mkText s]+++-- | Create a checkbox field+checkbox :: String     -- ^ name of the field+         -> String     -- ^ value of the field+         -> Bool       -- ^ flag whether the checkbox should be checked+         -> Attributes -- ^ additional 'Attributes'+         -> XmlTree+checkbox name _value checked attrs = input name attrs' --inputWithValue name value attrs'+  where+    attrs' = ("type","checkbox") : checkedAttr checked ++ attrs+++-- | Create a radio button.+--   The id will be generated by concatenating the name, an underscore and+--   the value: /name ++ '_':value/. If you want to explicitly set the id+--   just put the id into the 'Attributes'.+radio :: String     -- ^ name of the field+      -> String     -- ^ value of the field+      -> Bool       -- ^ flag whether the radio button should be checked+      -> Attributes -- ^ additional 'Attributes'+      -> XmlTree+radio name value checked attrs = inputWithValue name value attrs'+  where+    attrs' =  ("type", "radio") : checkedAttr checked ++ attrs ++ [("id",name ++ '_':value)]++-- | Create an checked attribute+checkedAttr :: Bool -> [(String, String)]+checkedAttr b = [("checked", "checked") | b]+++-- --------------------------------------------------------------------------+-- Input: text, textarea, password, hidden, submit button, fileupload+-- --------------------------------------------------------------------------++-- | Create a text input field+textfield :: String      -- ^ name of the text field+          -> String      -- ^ value of the text field+          -> Attributes  -- ^ additional 'Attributes'+          -> XmlTree+textfield name value attrs = inputWithValue name value attrs'+  where attrs' =  ("type", "text") : attrs+++-- | Create a textarea field+textarea :: String     -- ^ name of the textarea field+         -> String     -- ^ value of the textarea field+         -> Attributes -- ^ additional 'Attributes'+         -> XmlTree+textarea name value attrs = contentTag "textarea" attrs' [mkText value]+  where attrs' = attrs ++ [("name", name), ("id", name)]+++-- | Create a password field+password :: String -> String -> Attributes -> XmlTree+password name value attrs = inputWithValue name value attrs'+  where attrs' = ("type", "password") : attrs+++-- | Create a hidden field+hidden :: String     -- ^ name of the hidden field+       -> String     -- ^ value of the hidden field+       -> Attributes -- ^ additional 'Attributes'+       -> XmlTree+hidden name value attrs = inputWithValue name value attrs'+  where attrs' = ("type", "hidden") : attrs+++-- | Create a submit button+submit :: String -> Attributes -> XmlTree+submit value attrs = inputWithValue "commit" value attrs'+  where attrs' = ("type", "submit") : attrs++submitWithName :: String -> String -> Attributes -> XmlTree+submitWithName name value attrs = inputWithValue name value attrs'+  where attrs' = ("type", "submit") : attrs++-- | Create a fileupload field+fileupload :: String -> Attributes -> XmlTree+fileupload name attrs = input name attrs'+  where attrs' =  ("type", "file") : attrs+++-- Create a input field with a value+inputWithValue :: String -> String -> Attributes -> XmlTree+inputWithValue name value attrs = input name attrs'+  where attrs' = ("value", value) : attrs+++-- Create a input field+input :: String -> Attributes -> XmlTree+input name attrs = tag "input" attrs'+  where attrs' = ("name", name) : ("id", name) : attrs+++-- --------------------------------------------------------------------------+-- labels, links, images+-- --------------------------------------------------------------------------++form :: String -> String -> String -> Attributes -> XmlTrees -> XmlTree+form name method action attrs = contentTag "form" attrs'+  where attrs' = ("id", name) : ("method", method) : ("action", action) : attrs++-- | Create a label with the name as value+slabel :: String -> Attributes -> XmlTree+slabel name = label name name+++-- | Create a label with name and value+label :: String -> String -> Attributes -> XmlTree+label name value attrs = contentTag "label" attrs' [mkText value]+  where attrs' = ("for", name) : attrs+++-- | Create a link with a text to show+textlink :: String -> String -> XmlTree+textlink target content = link target [mkText content]++-- | Create a link with an arbitrary content+link :: String -> XmlTrees -> XmlTree+link target = linkA target []++-- | Create a link with an arbitrary content+linkA :: String -> Attributes -> XmlTrees -> XmlTree+linkA target attrs = contentTag "a" attrs'+  where attrs' = ("href", target) : attrs+++-- | Create an image element+image :: String -> String -> Attributes -> XmlTree+image title src attrs = tag "img" attrs'+  where attrs' = [("alt", title), ("title", title), ("src", src)] ++ attrs+
+ src/Hawk/View/Template/Helper/TagHelper.hs view
@@ -0,0 +1,44 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   Helper functions for creating xml tags.
+-}
+-- --------------------------------------------------------------------------++module Hawk.View.Template.Helper.TagHelper+  ( module Text.XML.HXT.DOM.XmlNode+  , module Text.XML.HXT.DOM.TypeDefs+  , contentTag+  , tag+  , text+  , showtext+  ) where++import Text.XML.HXT.DOM.XmlNode+import Text.XML.HXT.DOM.TypeDefs+import qualified Data.Map as M++text :: String -> XmlTree+text = mkText++showtext :: Show a => a -> XmlTree+showtext = text . show++contentTag :: String -> Attributes -> XmlTrees -> XmlTree+contentTag name attrs children = mkElement qn al children+  where+    qn = mkName name+    al = map (\(an, av) -> mkAttr (mkName an) [mkText av]) $ unique attrs+    unique = M.toList . M.fromList++tag :: String -> Attributes -> XmlTree+tag name attrs = contentTag name attrs []+
+ src/Hawk/View/Template/HtmlHelper.hs view
@@ -0,0 +1,23 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  $Id: Main.hs 57 2009-05-29 11:33:59Z inf6254 $++   Helper functions for creating xhtml tags for forms
+-}
+-- --------------------------------------------------------------------------+module Hawk.View.Template.HtmlHelper+  ( module Hawk.View.Template.Helper.FormHelper+  , module Hawk.View.Template.Helper.DateHelper+  , module Hawk.View.Template.Helper.TagHelper+  ) where++import Hawk.View.Template.Helper.FormHelper+import Hawk.View.Template.Helper.DateHelper+import Hawk.View.Template.Helper.TagHelper
+ src/Hawk/View/Template/Interpreter.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE Arrows, TemplateHaskell #-}+module Hawk.View.Template.Interpreter+  ( evalTemplate, bind, bindAttribute, prepareDoc, bindTyped, BindTree, prepareDoc', hawkPrefix+  ) where++-- Hawk+import Hawk.Controller.Types+  ( ResponseState (..)+  , RequestEnv (..)+  , EnvController+  , runController+  , StateController+  )+import Data.ByteString.Lazy.UTF8 (fromString)+import Data.ByteString.Lazy (ByteString)+import qualified Data.EitherMapTree as E+import Hack++-- Xml processing+import Text.XML.HXT.Arrow as Arrow+import qualified Text.XML.HXT.DOM.ShowXml as ShowXml+import qualified Text.XML.HXT.DOM.QualifiedName as QN++-- other stuff+import qualified Data.Map as M+import Control.Monad.State (StateT, runStateT, liftIO, get, put)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Either (runEitherT, returnLeft)+import Data.Maybe (fromMaybe)+import Hawk.Controller.Responses+
+-- logging+import qualified System.Log.Logger as Logger+import System.Log.Logger.TH (deriveLoggers)++$(deriveLoggers "Logger" [Logger.DEBUG, Logger.WARNING])+++type HawkArrow = IOSLA (XIOState (RequestEnv, ResponseState))++debugA :: ArrowIO a => a String ()+debugA = arrIO debugM+{-+debugA' :: (ArrowIO a, Show b) => a b b+debugA' = arr id &&& arrIO (debugM . show) >>> arr (\(x,_) -> x)+-}++-- | The Prefix of the hawk namespace+hawkPrefix :: String
+hawkPrefix = "hawk"
++-- | Create a qualified name for the hawk prefix
+hawkQName :: String -> QN.QName
+hawkQName l = QN.mkQName hawkPrefix l ""+-- TODO use url not prefix++-- TODO catch errors+evalTemplate :: (XmlTree -> StateController [XmlTree]) -> FilePath -> StateController ByteString+evalTemplate f fp = do+  env <- ask+  state <- get+  (state', res) <- liftIO $ runIOSLA (mainA f) (Arrow.initialState (env, state)) fp+  put $ snd $ xio_userState state'+  case res of+    (Left resp   : _) -> returnLeft resp+    (Right body' : _) -> return $ fromString body'+    _                 -> returnLeft $ errorResponse $ fromString "error in template"++--  liftM fromString $ EitherT $ return $ head res+  -- TODO handel result with not one result++-- --------------------------------------------------------------------------+-- General template processing+-- --------------------------------------------------------------------------++-- | process a file with all controllers. +mainA :: (XmlTree -> StateController [XmlTree]) -> HawkArrow String (Either Response String)+mainA rw = prepareDoc+     >>> invokeController rw+     >>> Arrow.right (unlistA+                     >>> processTD interpreteLast+                     >>> headMerge+                     >>> clearNamespace+                     >>> writeDocumentToString [(a_no_empty_elements,v_1), (a_indent, v_1), (a_output_html,v_1), (a_output_encoding, utf8), (a_add_default_dtd, v_1)]+                     )+++prepareDoc :: IOStateArrow s String XmlTree+prepareDoc = readDoc >>> processTD interpreteTag++prepareDoc' :: IOStateArrow s String XmlTree+prepareDoc' = readDoc >>> processTD interpreteTag'++isInterpretableTag :: ArrowXml a => a XmlTree XmlTree+isInterpretableTag = isElem >>> hasNamePrefix hawkPrefix++processTD :: ArrowXml a => a XmlTree XmlTree -> a XmlTree XmlTree+processTD = processTopDown . (`when` isInterpretableTag)++interpreteTag :: IOStateArrow s XmlTree XmlTree+interpreteTag = choiceA+    [ isEmbed    :-> embed+    , isIgnore   :-> (ignore >>> processTD interpreteTag)+    , isSurround :-> surround+    , this       :-> this+    ]++interpreteTag' :: IOStateArrow s XmlTree XmlTree+interpreteTag' = choiceA+    [ isIgnore   :-> (ignore >>> processTD interpreteTag')+    , isSurround :-> surround'+    , this       :-> this+    ]+++interpreteLast :: HawkArrow XmlTree XmlTree+interpreteLast = choiceA+    [ isEmbed        :-> (removeEmbed >>> processTD interpreteLast)+    , isMessage      :-> message+    , isErrorMessage :-> errorMessage+    , this           :-> (remaining >>> processTD interpreteLast)+    ]++-- --------------------------------------------------------------------------+-- Arrows for specific tags+-- --------------------------------------------------------------------------++removeEmbed :: ArrowXml a => a XmlTree XmlTree+removeEmbed = getChildren -- TODO handle tag with no children++-- | Check whether the current element is an embed tag+isEmbed :: ArrowXml a => a XmlTree XmlTree+isEmbed = hasLocalPart "embed" >>> hasAttr "what"++-- | Embed another template into the current template+embed :: IOStateArrow s XmlTree XmlTree+embed = applyA $  getAttrValue "what" >>>  listA loadTemplateA >>> arr setChildren+{- proc t -> do+  what  <- getAttrValue "what"  -< t+  debugA -< "embedding template '" ++ what ++ "'"+  loadTemplateA                 -< what -}++isIgnore :: ArrowXml a => a XmlTree XmlTree+isIgnore = hasLocalPart "ignore"++ignore :: ArrowXml a => a XmlTree XmlTree+ignore = getChildren++isMessage :: ArrowXml a => a XmlTree XmlTree+isMessage = hasLocalPart "message" >>> hasAttr "type"++message :: HawkArrow XmlTree XmlTree+message = proc t -> do+  msgtype <- getAttrValue "type" -< t+  (_,us)  <- getUserState        -< ()+  case M.lookup msgtype (flash us) of+    Nothing  -> none   -< ()+    Just msg -> do+       text  <- mkText -< msg+       replace <-  arr replaceContent -< text+       (getChildren <<< replace) -<< t++isErrorMessage :: ArrowXml a => a XmlTree XmlTree+isErrorMessage = hasLocalPart "error" >>> hasAttr "for"++errorMessage :: HawkArrow XmlTree XmlTree+errorMessage = proc t -> do+  msgFor <- getAttrValue "for" -< t+  (_,us) <- getUserState       -< ()+  case M.findWithDefault [] msgFor (errors us) of+    [] -> none -< ()+    es -> do+       let errs = map (\(a,e) -> if null a then e else a ++ " : " ++ e) es+       texts <- (selem "ul" [unlistA >>> selem "li" [mkText]]) -< errs+       replace <- arr replaceContent -< texts+       (getChildren <<< replace) -<< t++isContent :: ArrowXml a => a XmlTree XmlTree+isContent = hasNamePrefix hawkPrefix >>> hasLocalPart "content"++replaceContent :: ArrowXml a => XmlTree -> a XmlTree XmlTree+replaceContent content = processTopDown (constA content `when` isContent)++isSurround :: ArrowXml a => a XmlTree XmlTree+isSurround = hasLocalPart "surround" >>> hasAttr "with" >>> hasAttr "at"++-- Surround template with another template.+surround :: IOStateArrow s XmlTree XmlTree+surround = proc t -> do+  children <- listA getChildren    -< t+  at       <- getAttrValue "at"    -< t+  with     <- getAttrValue "with"  -< t+  -- Load the surrounding template+  outer    <- loadTemplateA         -< with+  -- Insert the original template into the surrounding template+  debugA -< "surrounding with '" ++ with ++ "' at '" ++ at ++ "'"+  bound    <- bindA                -< ([(at, children)], outer)+  processTD interpreteTag          -< bound++surround' :: IOStateArrow s XmlTree XmlTree+surround' = proc t -> do+  children <- listA getChildren    -< t+  at       <- getAttrValue "at"    -< t+  with     <- getAttrValue "with"  -< t+  -- Load the surrounding template+  outer    <- loadTemplateA         -< with+  -- Insert the original template into the surrounding template+  debugA -< "surrounding with '" ++ with ++ "' at '" ++ at ++ "'"+  bound    <- bindA                -< ([(at, children)], outer)+  processTD interpreteTag'          -< bound++remaining :: HawkArrow XmlTree XmlTree+remaining = proc t -> do+    n  <- arr (ShowXml.xshow . (:[])) -< t+    arrIO warningM -< "There are remaining not replaced hawk-Tag: " ++ n+    s <- returnA -< "True" --arr (fromMaybe "" . lookup "hide_hol" .  environmentOptions) <<< getUserState -< t+    case s of+        "True" -> ignore -< t+        _      -> this   -< t+++-- --------------------------------------------------------------------------+-- Helper arrows+-- --------------------------------------------------------------------------++loadTemplateA :: IOStateArrow s String XmlTree
+loadTemplateA =  runInLocalURIContext readDoc -- [(a_validate, v_0)]+                 >>>
+                 getChildren -- discard root node++readDoc :: IOStateArrow s String XmlTree+readDoc = readFromDocument [(a_parse_html, v_1)] -- >>> propagateNamespaces++-- | lift a IOState Monad in a IOState Arrow+arrM :: (t -> StateT s EnvController a) -> IOSLA (XIOState (RequestEnv, s)) t a+arrM f = proc a -> do+  (env,state) <- getUserState -< ()+  (b,state') <- arrIO (\(a,(e,s)) -> runReaderT (runController (runStateT (f a) s)) e) -< (a, (env,state))+  setUserState -< (env,state')+  returnA -< b+++invokeController :: (XmlTree -> StateController [XmlTree]) -> HawkArrow XmlTree (Either Response [XmlTree])
+invokeController c = arrM $ runEitherT . c++-- --------------------------------------------------------------------------+-- Head merge+-- --------------------------------------------------------------------------
++-- | merge all head Elements in a XmlTree+-- TODO only to the first head, need to delete the others+headMerge :: ArrowXml a => a XmlTree XmlTree+headMerge = headList &&& removeHeadsFromBody+    >>>+    applyA (arr (\(heads,tree) -> constA tree >>> insertHeads heads))+
+-- | get the content of all head Elements+headList ::  ArrowXml a => a XmlTree [XmlTree]+headList = listA (heads >>> getChildren)+    where+    heads = deep $ isElem >>> hasName "head"++removeHeadsFromBody :: ArrowXml a => a XmlTree XmlTree+removeHeadsFromBody = processTopDown+    $ removeHeads `when` isBody+    where+    isBody = isElem >>> hasName "body"++removeHeads :: ArrowXml a => a XmlTree XmlTree+removeHeads = processTopDown+    $ none `when` isHead+    where+    isHead = isElem >>> hasName "head"++insertHeads :: ArrowXml a => [XmlTree] -> a XmlTree XmlTree+insertHeads h = processTopDown+        $ mkelem "head" [] (map constA h) `when` isHead+        where+        isHead = isElem >>> hasName "head"++-- --------------------------------------------------------------------------+-- Binding+-- --------------------------------------------------------------------------
++type BindTree = E.EitherMapTree String [XmlTree]++bindTyped :: XmlTree+    -> BindTree+    -> [(String, [(String, String)])]+    -> [XmlTree]+bindTyped x t _ = runLA (bindTypedA t) x++bindTypedA :: (ArrowChoice a, ArrowXml a)  => BindTree -> a XmlTree XmlTree+bindTypedA t = processTopDown (bindNode `when` (isBind `orElse` isEmbed))+    where+    bindNode = applyA (getBindName >>> arr (helper t))+    helper :: (ArrowChoice a, ArrowXml a) => BindTree -> String -> a XmlTree XmlTree+    helper t' n = case E.lookup n t' of+        Just v -> case v of+            Left  t'' -> applyA (constA t'' >>> unlistA >>> arr bindTypedA)+            Right x  -> constA x >>> unlistA+        Nothing -> this++isBind :: ArrowXml a => a XmlTree XmlTree+isBind = isElem >>> hasQName (hawkQName "bind")++getBindName :: ArrowXml a => a XmlTree String+getBindName = choiceA [isBind :-> getAttrValue "name"+                  ,isEmbed :-> getAttrValue "what"+                  ]+                  
+-- Arrow version of bind
+bindA :: ArrowXml cat => cat ([(String, [XmlTree])], XmlTree) XmlTree
+bindA = applyA $ arr $ \(m, tree) -> constA tree >>> bind m+
+-- |Inserts the values of a list of (name, value) pairs into a template at the
+--  positions defined by bind-Tags.+bind :: (ArrowXml cat) => [(String, [XmlTree])] -> cat XmlTree XmlTree
+bind m = processTopDown (replaceFrom m `when` isBind')
+  where+  isBind' = isElem >>> hasQName (hawkQName "bind") >>> hasAttrValue "name" (flip elem keys)+  keys = map fst m++lookupA :: Arrow a  => a (String, [(String, [XmlTree])]) [XmlTree]
+lookupA = arr $ fromMaybe [] . uncurry lookup
+
+replaceFrom :: (ArrowXml cat) => [(String, [XmlTree])] -> cat XmlTree XmlTree+replaceFrom m = proc t -> do+  name       <- getAttrValue "name" -< t+  unlistA <<< lookupA               -< (name, m)++bindAttribute :: ArrowXml cat => [(String, [XmlTree])] -> cat XmlTree XmlTree+bindAttribute m = processTopDown $ replaceAttribute m `when` hasBindAttr+    where+    hasBindAttr = isElem >>> getQAttrValue0 (hawkQName "bind")
++replaceAttribute :: ArrowXml cat => [(String, [XmlTree])] -> cat XmlTree XmlTree+replaceAttribute m = addAttrl (getQAttrValue0 (hawkQName "bind") &&& constA m >>> lookupA >>> unlistA)+    >>>+    removeQAttr (hawkQName "bind")++-- --------------------------------------------------------------------------+-- clearNamespace+-- --------------------------------------------------------------------------++-- | Remove the hawk namespace
+clearNamespace :: (ArrowXml a) => a XmlTree XmlTree+clearNamespace = processTopDown (removeAttr ("xmlns:" ++ hawkPrefix) `when` isHtml) -- TODO do not use hawk prefix, use full Namespace+    where isHtml = isElem >>> hasName "html"
+ src/Hawk/View/Template/ToXhtml.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeSynonymInstances #-}+module Hawk.View.Template.ToXhtml where++import Hawk.View.Template.HtmlHelper+import Data.Stringable++class ToXhtml a where+    toXhtml :: a -> [XmlTree]++instance Stringable a => ToXhtml a where+    toXhtml = toXhtml . text . toString++instance ToXhtml XmlTree where+    toXhtml = (:[])++instance ToXhtml [XmlTree] where+    toXhtml = id
+ src/Hawk/View/TemplateView.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}+module Hawk.View.TemplateView+  ( TemplateView (..)+  , XmlTree+  , bind+  , xhtml+  , xhtmlTypedView+  , xhtmlTemplateView+  , subTemplate+  , getAttribute+  , lookupAttribute+  , typedView+  , typedViewWithAttributes+  ) where++import Hawk.Controller.Types+    (StateController, Route(Route), View(..), HasState+    , templatePath, configuration, request, Routing)+import qualified Hawk.View.Template.Interpreter as Interpreter+import Hawk.View.Template.DataType+import Hawk.Controller.Util.Text+import Hawk.Controller.Util.Uri+import Hawk.Controller.Routes+import qualified Text.XML.HXT.DOM.XmlNode as XN++import Hack+import Text.XML.HXT.Arrow+import System.FilePath (joinPath)+import System.Directory (doesFileExist)+import Data.ByteString.Lazy (empty)+import Control.Monad.Either+import Control.Monad.Reader (asks)+import Hawk.View.Template.Interpreter (hawkPrefix)++data TemplateView a = TemplateView+  { templateName :: String+  , toXhtml      :: XmlTree -> a -> StateController [XmlTree]+  }++instance View (TemplateView a) where+  type Target (TemplateView a) = a+  render a b = do+    (Route c _ ) <- asks $ dispatch . unescapeUri . pathInfo . request+    tp <- findTemplateM c $ templateName a+    case tp of+      Nothing -> return empty+      Just f  -> Interpreter.evalTemplate (flip (toXhtml a) b) f++typedView :: Bindable b => String+    -> (a -> StateController b)+    -> TemplateView a+typedView n t = TemplateView+  { templateName = n+  , toXhtml      = \x a -> do+      t' <- t a+      return $ Interpreter.bindTyped x (bindable t') []+  }++typedViewWithAttributes :: Bindable b => String+    -> (a -> StateController (b, [(String, [(String, String)])]))+    -> TemplateView a+typedViewWithAttributes n t = TemplateView+  { templateName = n+  , toXhtml      = \x a -> do+      (t', l) <- t a+      return $ Interpreter.bindTyped x (bindable t') l+  }++xhtml :: (View a) => String -> StateController (Target a) -> a -> [Routing]+xhtml s a v = [(s,c),(s++".xhtml",c)]+  where c = a >>= render v++xhtmlTypedView :: (Bindable b, View (TemplateView a)) =>+                String -> StateController a -> (a -> StateController b) -> [Routing]+xhtmlTypedView = xhtmlView typedView++xhtmlTemplateView+  :: (View (TemplateView a)) =>  String+     -> StateController a+     -> (XmlTree -> a -> StateController [XmlTree])+     -> [Routing]+xhtmlTemplateView = xhtmlView TemplateView++xhtmlView :: (View (TemplateView a)) => (String -> c -> TemplateView a) -> String -> StateController a -> c -> [Routing]+xhtmlView f s a = xhtml s a . f s++bind :: XmlTree -- The Template+    -> [(String, [XmlTree])] -- The Pairs of bind name and the inserting XML+    -> [(String, [(String, String)])] -- The Pairs for the Attribute bindings+    -> [XmlTree]+bind t m a = runLA (Interpreter.bind m >>> Interpreter.bindAttribute a' >>> getChildren) t+  where+  a' = map (second (map (\(k,v) -> XN.mkAttr (mkName k) $ (:[]) $ XN.mkText v))) a++subTemplate :: XmlTree -> String -> [XmlTree]+subTemplate tree name = runLA (deep arrow) tree+  where arrow = isElem+                >>> hasNamePrefix hawkPrefix+                >>> hasLocalPart "bind"+                >>> hasAttrValue "name" (== name)++getAttribute :: XmlTree -> String -> String+getAttribute t a = head $ runLA (getAttrValue a) t++lookupAttribute :: XmlTree -> String -> Maybe String+lookupAttribute t a = case runLA (getAttrValue0 a) t of+  []    -> Nothing+  (v:_) -> Just v++findTemplateM :: (MonadIO m, HasState m) => String -> String -> m (Maybe FilePath)+findTemplateM c s = do+  tp <- asks $ templatePath . configuration+  let fullPath = joinPath [tp, firstUpper c, s ++ ".xhtml"]+  fileExists <- liftIO $ doesFileExist fullPath+  if fileExists then+    return $ Just fullPath+    else return Nothing+
+ src/Hawk/View/TextView.hs view
@@ -0,0 +1,35 @@+-- --------------------------------------------------------------------------
+{- |
+   Module      :  $Header$
+   Copyright   :  Copyright (C) 2009 Björn Peemöller, Stefan Roggensack
+   License     :  BSD3
+
+   Maintainer  :  {inf6254, inf6509}fh-wedel.de
+   Stability   :  experimental
+   Portability :  portable
+   Version     :  
+
+   
+-}
+-- --------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+module Hawk.View.TextView+  ( TextView (..)+  , textView+  ) where++import Control.Monad (liftM)+import Data.ByteString.Lazy.UTF8 (fromString)+import Hawk.Controller.Types+  ( StateController+  , View (..)+  )++data TextView a = TextView { toText :: a -> StateController String }++textView :: Show a => TextView a+textView = TextView $ return . show++instance View (TextView a) where+  type Target (TextView a) = a+  render tv = liftM fromString . toText tv