frame (empty) → 0.1
raw patch · 17 files changed
+1850/−0 lines, 17 filesdep +HDBCdep +HDBC-odbcdep +HTTPsetup-changed
Dependencies added: HDBC, HDBC-odbc, HTTP, MissingH, base, bytestring, containers, directory, ghc-binary, happstack-fastcgi, happstack-server, haskell98, haskelldb, haskelldb-hdbc, haskelldb-hdbc-odbc, mtl, old-time, pretty, utf8-string
Files
- LICENSE +0/−0
- Setup.hs +4/−0
- frame.cabal +60/−0
- src/Frame.lhs +21/−0
- src/Frame/Config.lhs +24/−0
- src/Frame/Data.lhs +22/−0
- src/Frame/GUI.lhs +152/−0
- src/Frame/Model.lhs +112/−0
- src/Frame/Router.lhs +57/−0
- src/Frame/Server.lhs +103/−0
- src/Frame/Session.lhs +185/−0
- src/Frame/Shell.lhs +304/−0
- src/Frame/State.lhs +140/−0
- src/Frame/Types.lhs +280/−0
- src/Frame/Utilities.lhs +136/−0
- src/Frame/Validation.lhs +85/−0
- src/Frame/View.lhs +165/−0
+ LICENSE view
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++import Distribution.Simple+main = defaultMain
+ frame.cabal view
@@ -0,0 +1,60 @@+Name: frame+Version: 0.1+Cabal-version: >= 1.2+Build-type: Simple+Copyright: Adam Dunkley+Maintainer: "Adam Dunkley" <acd07u@cs.nott.ac.uk>+Stability: experimental+Author: Adam Dunkley+License: BSD3+License-file: LICENSE+Category: Web+Synopsis: A simple web framework.+Description: A simple web framework.++Executable frame-shell+ Main-is: Frame/Shell.lhs+ Hs-source-dirs: src+ Build-Depends:+ pretty+Library+ Build-Depends:+ base >= 2 && < 4,+ old-time,+ ghc-binary,+ haskell98,+ directory,+ bytestring,+ utf8-string,+ MissingH,+ HDBC-odbc,+ HDBC,+ haskelldb-hdbc-odbc,+ haskelldb-hdbc,+ haskelldb,+ mtl,+ containers,+ happstack-server,+ happstack-fastcgi,+ HTTP+ Extensions:+ UndecidableInstances,+ MultiParamTypeClasses,+ FunctionalDependencies,+ FlexibleInstances,+ FlexibleContexts+ Exposed-Modules:+ Frame,+ Frame.Config,+ Frame.Data,+ Frame.GUI,+ Frame.Model,+ Frame.Router,+ Frame.Server,+ Frame.Session,+ Frame.State,+ Frame.Types,+ Frame.Utilities,+ Frame.Validation,+ Frame.View+ Hs-source-dirs: src
+ src/Frame.lhs view
@@ -0,0 +1,21 @@+> module Frame (+> module Frame.Server,+> module Frame.Utilities,+> module Frame.Data,+> module Frame.Session,+> module Frame.Config,+> module Frame.State,+> module Frame.Types,+> module Frame.Validation,+> (-.-)+> ) where++> import Frame.Server+> import Frame.Session+> import Frame.Data+> import Frame.Config+> import Frame.State+> import Frame.Types+> import Frame.Utilities+> import Frame.Validation+> import Frame.Model ((-.-))
+ src/Frame/Config.lhs view
@@ -0,0 +1,24 @@+> {-|+> Module to define a configuration to be provided when launching framework+> applications+> -}+> module Frame.Config (+> Config (..),+> FrameConfig,+> asks+> ) where++> import Database.HaskellDB.DBLayout+> import Control.Monad.Reader++> data Config = Config {+> database :: DBInfo -- ^ The database info+> , dbName :: String -- ^ The name for the database+> , dbURL :: String -- ^ The ODBC URL for the database+> , sessionPath :: String -- ^ File system path to sessions+> , sessionId :: String -- ^ Session ID+> , css :: [String] -- ^ Stylesheets to attach to the view+> }++> class (MonadReader Config m) => FrameConfig m+> instance (MonadReader Config m) => FrameConfig m
+ src/Frame/Data.lhs view
@@ -0,0 +1,22 @@+> module Frame.Data (+> Data (..)+> ) where++> import Frame.GUI+> import qualified Data.ByteString.Lazy as L++> -- | A collection of views which can be streamed to the client by the server+> data Data +> = View GUI -- ^ A full view+> | ViewPart [Container] -- ^ A partial view+> | File L.ByteString -- ^ A file+> | Error404 -- ^ File not found, 404 HTTP response+> | Redirect URL -- ^ Redirection++> instance Composable Data where+> (View g) <+ c = View $ g <+ c+> (ViewPart cs) <+ c = ViewPart $ cs ++ [c]+> d <+ _ = d+> c +> (View g) = View $ c +> g+> c +> (ViewPart cs) = ViewPart $ (c:cs)+> _ +> d = d
+ src/Frame/GUI.lhs view
@@ -0,0 +1,152 @@+> {-|+> A subset of the GUI required to build a useful view+> -}+> module Frame.GUI (+> -- * GUI+> GUI (..),+> Composable (..),+> Container (..),+> Class,+> URL,+> Element (..),+> Element' (..),+> -- ** Forms+> Label,+> FormElement (..),+> FormValue,+> ) where++> import Frame.Utilities+> import Database.HaskellDB.DBLayout+> import Frame.Types++> class Composable a where+> (<+) :: a -> Container -> a+> (+>) :: Container -> a -> a++> type Class = String ++> -- | A generic GUI whose various instances define how it should be output (e.g. Show outputs HTML).+> data GUI +> = Frame String [URL] [Container] -- ^ A frame with a title, some style and a set of containers++> instance Composable GUI where+> (Frame t s cs) <+ c = Frame t s $ cs ++ [c]+> c +> (Frame t s cs) = Frame t s $ c:cs++> instance Show GUI where+> show (Frame t s cs) = "<html>\n\t<head>\n\t\t<title>" ++ +> t ++ "</title>\n\t" ++ showCSS s ++ "<body>\n" ++ +> concatMap show cs ++ +> "\n\t</body>\n</html>"++> showCSS :: [String] -> String+> showCSS [] = ""+> showCSS (c:cs) = "<link rel=\"stylesheet\" href=\"" ++ c ++ "\" type=\"text/css\" />\n\t</head>\n\t" ++ showCSS cs++> -- | Contains various 'block level' elements+> data Container +> = Panel [Container] [Class] -- ^ Panel matches up with a div when output as HTML+> | Paragraph [Element] [Class] -- ^ Paragraphs can only only contain elements+> | Code String -- ^ Code+> | Quote [Container] -- ^ Quote+> | Header Int [Element] -- ^ Header (int is size)+> | List [[Container]] [Class] -- ^ Lists contain list items+> | NumList [[Container]] [Class] -- ^ Lists contain list items+> | Form [FormElement] [Class] -- ^ A form+> | Error [Container] -- ^ Error pane+> | Line+> | Empty++> instance Composable Container where+> (Panel cs s) <+ c = Panel (cs ++ [c]) s+> (Quote cs) <+ c = Quote (cs ++ [c])+> (List css s) <+ c = List (css ++ [[c]]) s+> (NumList css s) <+ c = NumList (css ++ [[c]]) s+> (Error cs) <+ c = Error (cs ++ [c])+> c <+ c' = Panel (c:[c']) []+> c +> (Panel cs s) = Panel (c:cs) s+> c +> (Quote cs) = Quote (c:cs)+> c +> (List css s) = List ([c]:css) s+> c +> (NumList css s) = NumList ([c]:css) s+> c +> (Error cs) = Error (c:cs)+> c' +> c = Panel (c:[c']) [] ++> instance Show Container where+> show (Panel cs c) = "<div" ++ showClass c ++ ">" ++ concatMap show cs ++ "</div>"+> show (Paragraph es c) = "<p" ++ showClass c ++ ">" ++ concatMap show es ++ "</p>" +> show (Code s) = "<code>" ++ s ++ "</code>" +> show (Quote cs) = "<blockquote>" ++ concatMap show cs ++ "</blockquote>" +> show (Header s es) = "<h" ++ show s ++ ">" ++ concatMap show es ++ "</h" ++ show s ++ ">" +> show (List is c) = "<ul" ++ showClass c ++ ">" ++ concatMap showListItem is ++ "</ul>"+> show (NumList is c) = "<ol" ++ showClass c ++ ">" ++ concatMap showListItem is ++ "</ol>"+> show (Form fs c) = "<form" ++ showClass c ++ " method=\"post\">" ++ concatMap show fs ++ "</form>"+> show (Error s) = "<div class=\"error\">" ++ concatMap show s ++ "</div>"+> show Line = "<hr />"+> show Empty = ""++ +> showClass :: [String] -> String+> showClass [] = ""+> showClass cs = " class=\"" ++ showClasses cs ++ "\""+> showClasses :: [String] -> String+> showClasses [c] = c+> showClasses (c:cs) = c ++ " " ++ showClasses cs++> showListItem :: [Container] -> String+> showListItem cs = "\n\t\t<li>" ++ concatMap show cs ++ "</li>"++Some canonical types for URLs and Labels++> -- | A URL+> type URL = String++> data Element +> = Element Element' -- ^ Plain element+> | Link URL Element' -- ^ Element wrapped in a link+> | Strong [Element] -- ^ Element wrapped in a link+> | Emphasis [Element] -- ^ Element wrapped in a link+> | Break -- ^ Line break++> instance Show Element where+> show (Link u e) = "<a href=\"" ++ u ++ "\">" ++ show e ++ "</a>"+> show (Strong es) = "<strong>" ++ concatMap show es ++ "</strong>"+> show (Emphasis es) = "<em>" ++ concatMap show es ++ "</em>"+> show (Element e) = show e+> show Break = "<br />"++> data Element' +> = Text String -- ^ Textual element+> | Image URL String -- ^ Image element++> instance Show Element' where+> show (Image u s) = "<img src=\"" ++ u ++ "\" alt=\"" ++ s ++ "\" />" +> show (Text s) = s++> -- | A label+> type Label = String++> data FormElement +> = FormGroup [FormElement] Label -- ^ For grouping elements+> | TextField FieldName Label FormValue (Maybe Int) (Maybe Container) -- ^ Standard text box+> | HiddenField FieldName FormValue -- ^ Hidden field+> | TextArea FieldName Label FormValue (Maybe Container) -- ^ Larger text box+> | Button FieldName FormValue -- ^ Submit button+> | ButtonLink Label URL -- ^ Special textual button++> instance Show FormElement where+> show (FormGroup es l) = "<fieldset>" ++ ((length l == 0) ?? ("<legend>" ++ l ++ "</legend>")) ++ "<ul>" ++ concatMap show es ++ "</ul></fieldset>"+> show (TextField fn l fv ml (Just e)) = "<li class=\"error\">" ++ show e ++ "<label for=\"" ++ fn ++ "\">" ++ l ++ "</label><input type=\"text\" name=\"" ++ fn ++ "\" value=\"" ++ show fv ++ "\"" ++ showMaxLength ml ++ " /></li>"+> show (TextField fn l fv ml Nothing) = "<li><label for=\"" ++ fn ++ "\">" ++ l ++ "</label><input type=\"text\" name=\"" ++ fn ++ "\" value=\"" ++ show fv ++ "\"" ++ showMaxLength ml ++ " /></li>"+> show (HiddenField l fv) = "<input type=\"hidden\" name=\"" ++ l ++ "\" value=\"" ++ show fv ++ "\" />"+> show (TextArea l t fv (Just e)) = "<li class=\"error\">" ++ show e ++ "<label for=\"" ++ l ++ "\">" ++ t ++ "</label><textarea name=\"" ++ l ++ "\">" ++ show fv ++ "</textarea></li>"+> show (TextArea l t fv Nothing) = "<li><label for=\"" ++ l ++ "\">" ++ t ++ "</label><textarea name=\"" ++ l ++ "\">" ++ show fv ++ "</textarea></li>"+> show (Button l fv) = "<li><input type=\"submit\" name=\"" ++ l ++ "\" value=\"" ++ show fv ++ "\" /></li>"+> show (ButtonLink l u) = "<li><a href=\"" ++ u ++ "\">" ++ l ++ "</a></li>"++> showMaxLength :: Maybe Int -> String+> showMaxLength (Just i) = " maxlength=\"" ++ show i ++ "\""+> showMaxLength Nothing = ""++> -- | Form values are just wrapped types+> type FormValue = WrapperType
+ src/Frame/Model.lhs view
@@ -0,0 +1,112 @@+> -- | High level model helpers+> module Frame.Model (+> FrameIO,+> FrameModel,+> liftIO,+> module Database.HaskellDB,+> module Database.HaskellDB.BoundedList,+> module Database.HaskellDB.BoundedString,+> fieldName,+> tableName,+> (-.-),+> run,+> merge,+> field,+> posted,+> wrapStringField,+> wrapIntField,+> wrapMaybeIntField,+> wrapBoolField+> ) where++> import Database.HaskellDB+> import Database.HaskellDB.HDBC.ODBC+> import Database.HaskellDB.DBSpec.PPHelpers+> import Database.HaskellDB.DBSpec.DBSpecToDBDirect+> import Database.HaskellDB.BoundedList+> import Database.HaskellDB.BoundedString+> import Database.HaskellDB.Query (tableName, attributeName)+> import Database.HaskellDB.DBLayout hiding (fieldName)+> import Database.HaskellDB.PrimQuery+> import Database.HaskellDB.Database+> import Control.Monad.Trans++> import Frame.Types+> import Frame.Config+> import Frame.State+> import Frame.Validation++> class (MonadIO m) => FrameIO m+> instance (MonadIO m) => FrameIO m+ +> class (FrameConfig m, FrameState m, FrameIO m) => FrameModel m+> instance (FrameConfig m, FrameState m, FrameIO m) => FrameModel m++> withODBC :: MonadIO m => String -> (Database -> m a) -> m a+> withODBC u = (connect driver) [("DSN", u)]++> -- | Convenience function for a stringed representation fo a table and attribute+> ( -.- ) :: Table r -- ^ Table+> -> Attr f a -- ^ Attribute+> -> String -- ^ ''TableName.attributeName''+> t -.- a = fieldName (tableName t) $ attributeName a++> -- | Convenience function for creating a qualified attribute name+> fieldName :: String -- ^ Table name+> -> String -- ^ Attribute name+> -> String -- ^ ''TableName.attributeName''+> fieldName t f = t ++ "." ++ f++> -- | Execute a database function against the DB+> run :: FrameModel m +> => (Database -> m a) -- ^ The function that requires a database+> -> m a -- ^ The executed result+> run r = do +> u <- asks dbURL+> withODBC u r++> -- | Take the fields updated by some model action and merge them in to the state+> merge :: (FrameModel m) +> => m (Maybe Fields)+> -> m (Maybe Fields)+> merge mr = do+> mfs <- mr+> mergeFields mfs+> return mfs++> field :: (Wrappable a) +> => DBInfo +> -> FieldName+> -> a+> -> (FieldName, WrapperType)+> field d n f = (n, wrap d n f)++> {-| +> Should a form have been posted and all of the fields validate, run some+> computation which maps fields to a model (with an empty return type)+> -} +> posted :: FrameModel m +> => (Fields -> m a) -- ^ The computation to run+> -> m Bool -- ^ Did the computation succeed?+> posted f = do+> db <- asks database+> p <- gets post+> fs <- gets fields+> vs <- gets validators+> case (p && allValidated vs fs) of+> True -> do f $ purge db fs+> return True+> False -> return False++> wrapStringField :: Size n => FieldName -> BoundedList Char n -> (FieldName, WrapperType)+> wrapStringField fn b = (fn, WrapString (Just $ listBound b) $ fromBounded b)++> wrapBoolField :: FieldName -> Bool -> (FieldName, WrapperType)+> wrapBoolField fn v = (fn, WrapBool v)++> wrapIntField :: FieldName -> Int -> (FieldName, WrapperType)+> wrapIntField fn v = (fn, WrapInt v)++> wrapMaybeIntField :: FieldName -> Maybe Int -> (FieldName, WrapperType)+> wrapMaybeIntField fn (Just v) = wrapIntField fn v+> wrapMaybeIntField fn Nothing = (fn, WrapEmpty IntT)
+ src/Frame/Router.lhs view
@@ -0,0 +1,57 @@+> -- | Definitions and functions for building a router+> module Frame.Router (+> FrameRouter,+> fileFolder,+> Router,+> startRouter+> ) where++> import Data.List+> import Data.Map+> import qualified Data.ByteString.Lazy as L+> import Control.Monad.State (StateT, runStateT)+> import Control.Monad.Reader (ReaderT, runReaderT)++> import Frame.GUI+> import Frame.Data+> import Frame.Config+> import Frame.State+> import Frame.Types+> import Frame.Utilities+> import Frame.Validation+> import Frame.Model+> import Frame.View++> class (FrameConfig m, FrameState m, FrameIO m) => FrameRouter m+> instance (FrameConfig m, FrameState m, FrameIO m) => FrameRouter m++> -- | The 'fileFolder' function maps a URL to a filesystem folder+> fileFolder :: FrameRouter m => String -- ^ Folder on the file system+> -> [String] -- ^ Exploded URL+> -> m Data -- ^ Either an Error404 or the File+> fileFolder r fs = do+> f <- liftIO $ L.readFile (r ++ implodeUrl fs) `catch` (\_ -> return L.empty) +> case L.null f of +> True -> return Error404+> False -> return $ File f+++> -- | A router maps from a path (list of URL parts) to some 'Data'+> type Router = ([String] -> StateT Vars (ReaderT Config IO) Data)++> {-|+> Executes a given router and validators against request information from the+> server+> -}+> startRouter :: Router -- ^ The router being executed+> -> Config -- ^ The configuration+> -> Validators -- ^ Validators to check fields against+> -> [(FieldName, String)] -- ^ Initial fields (from the server)+> -> String -- ^ The URL (from the server)+> -> String -- ^ The session ID+> -> Bool -- ^ Whether this is an Ajax request+> -> IO Data -- ^ The data to be returned+> startRouter r c@Config{database=db} v vs u id a = let fs = fromList' db vs in+> do +> (d, _) <- runReaderT (runStateT (r $ explodeURL u) startState{fields=fs, validators=v, post=size fs /= 0, ajax=a}) c{sessionId=id}+> return d
+ src/Frame/Server.lhs view
@@ -0,0 +1,103 @@+> module Frame.Server (+> server,+> testServer+> ) where++> import qualified Frame.Router as Router+> import Network.HTTP.Headers+> import Happstack.Server +> import Happstack.Server.FastCGI (runFastCGIConcurrent, serverPartToCGI) +> import Control.Monad.Trans+> import Control.Monad.State (StateT)+> import Data.MIME.Types+> import qualified Data.ByteString.Lazy as L+> import qualified Data.ByteString.UTF8 as U++> import Frame.Validation+> import Frame.GUI+> import Frame.Data+> import Frame.Types+> import Frame.Config+> import Frame.Router+> import Frame.Session++> simpleCGI :: (ToMessage a) => ServerPartT IO a -> IO ()+> simpleCGI = runFastCGIConcurrent 10 . serverPartToCGI++> runCGI :: ServerPart Response -> IO ()+> runCGI s = do+> simpleCGI s++> run :: ServerPart Response -> IO ()+> run s = do+> simpleHTTP nullConf{ port = 3000 } s++> serverPart :: ([(String, String)] -> String -> String -> Bool -> IO Data) +> -> ServerPart Response+> serverPart f = do+> r <- askRq+> mid <- getDataFn $ lookCookieValue "framesid"+> case mid of+> Nothing -> do +> sid <- liftIO genSessionId +> addCookie (3600) (mkCookie "framesid" sid) +> routerToResponse f r sid+> (Just sid) -> do +> addCookie (3600) (mkCookie "framesid" sid) +> routerToResponse f r sid++> routerToResponse :: ([(String, String)] -> String -> String -> Bool -> IO Data)+> -> Request+> -> String+> -> ServerPart Response+> routerToResponse f r sid = withDataFn lookPairs $ +> \vs -> do d <- liftIO $ f vs (rqURL r) sid $ isAjax r+> dataToResponse d r++> dataToResponse :: Data+> -> Request+> -> ServerPart Response+> dataToResponse (File bs) r = return $ detectMime r $ fileResponse bs r+> dataToResponse Error404 r = notFound $ htmlContent $ toResponse $ "Could not find " ++ rqURL r+> dataToResponse (Redirect u) r = seeOther u $ toResponse $ "See " ++ u+> dataToResponse (ViewPart ps) r = return $ htmlContent $ toResponse $ concatMap show ps+> dataToResponse (View g) r = return $ htmlContent $ toResponse $ show g++> htmlContent :: Response -> Response+> htmlContent = setHeader "Content-Type" "text/html"++> fileResponse :: L.ByteString +> -> Request +> -> Response+> fileResponse bs r = lazyByteStringResponse (mimeType $ rqURL r) bs Nothing 0 $ fromIntegral $ L.length bs++> detectMime :: Request -> Response -> Response+> detectMime r = setHeader "Content-Type" (mimeType $ rqURL r)++> mimeType :: String -> String+> mimeType u = case guessType defaultmtd False u of+> (Just t, _) -> t+> (Nothing, _) -> "image/jpeg" ++> isAjax :: Request -> Bool+> isAjax r = case getHeader "X-Requested-With" r of+> (Just bs) -> U.toString bs == "XMLHttpRequest"+> Nothing -> False ++> -- | Start a test server+> testServer :: Router -- ^ The router to run+> -> Config -- ^ The configuration+> -> Validators -- ^ The validators to check fields against+> -> IO () -- ^ The server action+> testServer r c v = do+> putStr "\nA server is running at http://127.0.0.1:3000/\n"+> run $ serverPart $ startRouter r c v+> return ()++> -- | Start Frame using FastCGI+> server :: Router -- ^ The router to run+> -> Config -- ^ The configuration+> -> Validators -- ^ The validators to check fields against+> -> IO () -- ^ The server action+> server r c v = do+> runCGI $ serverPart $ startRouter r c v
+ src/Frame/Session.lhs view
@@ -0,0 +1,185 @@+> -- | Defines functions for state that can persist accross server requests+> module Frame.Session (+> -- * Session management+> startSession,+> saveSession,+> deleteSession,+> withSession,+> genSessionId,+> -- * Session manipulation+> getSessionField,+> delSessionField,+> copyToSession,+> copyFromSession,+> updateFlash,+> getDelFlash,+> flash+> ) where++> import Prelude hiding (lookup)+> import IO+> import Data.Map+> import qualified Data.Binary as B+> import Data.Binary.Get+> import qualified Data.ByteString.Lazy as L+> import System.Directory+> import System.Time++> import Frame.Router+> import Frame.View+> import Frame.Model (liftIO)+> import Frame.Types+> import Frame.State+> import Frame.Config+> import Frame.Utilities++> -- | Recovers a session from persistent storage+> startSession :: FrameRouter m => m Fields+> startSession = do+> p <- asks sessionPath+> i <- asks sessionId+> e <- liftIO $ doesFileExist $ p ++ i+> case e of+> True -> do +> f <- liftIO $ strictDecodeFile $ p ++ i+> let s = fromList f in do+> putSession s+> return s+> False -> return empty++> strictDecodeFile :: B.Binary a => FilePath -> IO a+> strictDecodeFile f = do+> h <- openFile f ReadMode+> o <- L.hGetContents h+> let !v = runGet (do v <- B.get+> return v) o+> hClose h+> return v++> -- | Saves a session to persistent storage+> saveSession :: FrameRouter m => m ()+> saveSession = do+> s <- gets session+> writeFields s+> return ()++> writeFields :: FrameRouter m => Fields -> m ()+> writeFields s = do +> p <- asks sessionPath+> i <- asks sessionId+> liftIO $ B.encodeFile (p ++ i) $ toList s+> return ()++> -- | Deletes a session from persistent storage+> deleteSession :: FrameRouter m => m ()+> deleteSession = do+> putSession $ fromList []+> p <- asks sessionPath+> i <- asks sessionId+> liftIO $ removeFile $ p ++ i+> return ()++> -- | Get a field from the session by FieldName+> getSessionField :: FrameReader m +> => FieldName -- ^ The FieldName to get from the session+> -> m (Maybe WrapperType) -- ^ The session field (if found)+> getSessionField fn = do +> s <- gets session+> return $ lookup fn s++> -- | Replaces the fields in the session+> putSession :: FrameState m => Fields -- ^ Fields to replace with+> -> m () -- ^ Nothing (but the modified state) is returned+> putSession s = do +> v <- get+> put v {session=s}++> -- | Associate a set of value with a FieldName in the state+> putSessionField :: FrameState m => FieldName -- ^ The FieldName being updated+> -> WrapperType -- ^ The (wrapped) value to be assigned+> -> m () -- ^ Nothing (but the modified state) is returned+> putSessionField fn s = do +> ss <- gets session+> v <- get+> put v {session=insert fn s ss}++> -- | Deletes a specific field in the session by the given field name+> delSessionField :: FrameState m +> => FieldName -- ^ FieldName to be deleted+> -> m ()+> delSessionField fn = do+> ss <- gets session+> v <- get+> put v {session=delete fn ss}++> -- | Copy a particular field to the session from the fields in the state+> copyToSession :: FrameState m => FieldName -- ^ The FieldName to be copied to the session+> -> m () -- ^ Nothing (but the modified state) is returned+> copyToSession fn = do +> mf <- getField fn+> case mf of+> (Just f) -> putSessionField fn f+> Nothing -> return ()++> -- | Copy a particular field to the session from the fields in the state+> copyFromSession :: (FrameState m, FrameConfig m)+> => FieldName -- ^ The FieldName to be copied from the session+> -> m () -- ^ Nothing (but the modified state) is returned+> copyFromSession fn = do +> mf <- getSessionField fn+> case mf of+> (Just f) -> putField fn f+> Nothing -> return ()++> -- | Overwrite a message to be flashed to the screen (persisting across requests)+> updateFlash :: FrameState m => String -- ^ Message to flash to the screen+> -> m () -- ^ Nothing (but the modified state) is returned +> updateFlash s = do +> ss <- gets session+> v <- get+> put v {session=insert "flash" (WrapString Nothing s) ss}++> getDelFlash :: FrameState m+> => m (Maybe String)+> getDelFlash = do+> mf <- getSessionField "flash"+> delSessionField "flash"+> return $ appMaybe unwrap mf++> -- | Given a router, flashes the current message to screen before deleting it+> flash :: FrameRouter m+> => m Data -- ^ The router to have the message flashed to+> -> m Data+> flash d = do+> d' <- d+> case d' of +> d@(View _) -> appFlash d+> d@(ViewPart _) -> appFlash d+> d -> return d++> appFlash :: (FrameRouter m) +> => Data -> m Data+> appFlash d = do +> mf <- getDelFlash+> return $ case mf of+> (Just s) -> Paragraph [text s] ["flash"] +> d+> Nothing -> d++> {-|+> A convenience function when running a router, starting and saving a function before+> and after the router is run+> -}+> withSession :: FrameRouter m +> => ([String] -> m a) -- ^ A router to run+> -> ([String] -> m a) -- ^ A router wrapped with a session+> withSession f ps = do+> startSession+> d <- f ps+> saveSession+> return d++> -- | Generate a unique session ID +> genSessionId :: IO String+> genSessionId = do +> TOD s ps <- getClockTime +> return $ show s ++ show ps
+ src/Frame/Shell.lhs view
@@ -0,0 +1,304 @@+> module Main where++> import IO+> import Database.HaskellDB hiding (describe, (!))+> import Database.HaskellDB.HDBC.ODBC+> import Database.HaskellDB.DBSpec.DBSpecToDBDirect+> import Database.HaskellDB.BoundedList+> import Database.HaskellDB.Query (tableName, attributeName)+> import Database.HaskellDB.DBLayout hiding (fieldName)+> import Database.HaskellDB.PrimQuery+> import Database.HaskellDB.Database hiding (describe)+> import Control.Monad.Trans++> import Database.HaskellDB.DBSpec.PPHelpers+> (MakeIdentifiers, moduleName, toType, identifier, checkChars,+> ppComment, newline, mkIdentCamelCase, )+> import qualified Database.HaskellDB.DBSpec.PPHelpers as PP+> import Data.Char (toLower, )+> import Text.PrettyPrint.HughesPJ+> import System.Directory+> import Data.List (isPrefixOf, (!!))+> import Control.Monad (unless)+> import System.Environment++> lcase :: String -> String+> lcase = map toLower++> imports :: Doc+> imports = text "import Frame"++> header :: Doc+> header = ppComment ["Generated by Frame"]++Main doc++> mainImports :: String -> Doc+> mainImports m = text "import" <+> text (m ++ ".Router") $$+> text "import" <+> text (m ++ ".Config") $$+> text "import" <+> text (m ++ ".Validation") <> newline $$+> text "import Frame" $$+> text "import Frame.Router"++> genMain :: String -- ^ Top-level module name+> -> Doc -- ^ list of module name, module contents pairs+> genMain m+> = header+> $$ text "module Main where"+> <> newline+> $$ imports $$ mainImports m+> <> newline+> $$ text "test :: IO ()"+> $$ text "test = testServer (withSession $ flash . router) config validations"+> <> newline+> $$ text "main :: IO ()"+> $$ text "main = server (withSession $ flash . router) config validations"++Config docs++> configImports :: String -> Doc+> configImports m = text "import Frame.Config" <> newline $$+> text "import" <+> text (m ++ ".DB")++> genConfig :: String -- ^ Top-level module name+> -> String -- ^ Database URL+> -> String -- ^ Database name+> -> String -- ^ Current path+> -> Doc -- ^ list of module name, module contents pairs+> genConfig m du dn cp+> = header+> $$ text "module" <+> text (m ++ ".Config") <+> text "where"+> <> newline+> $$ imports $$ configImports m+> <> newline+> $$ text "config = Config {database=" <> text dn <>+> text ", dbURL=" <> doubleQuotes (text du) <>+> text ", dbName=" <> doubleQuotes (text dn) <>+> text ", sessionPath=\"" <> text (cp ++ "/Sessions/") <> text "\", sessionId=\"\", css=[]}"+> <> newline+> $$ text "production = config"++Validation docs++> validationImports :: String -> [String] -> Doc+> validationImports m [] = text "import Data.Map (fromList)" <> newline+> validationImports m (r:rs) = validationImports m rs $$+> text "import" <+> text (m ++ ".DB." ++ r)++> genValidation :: String -- ^ Top-level module name+> -> [String]+> -> Doc -- ^ list of module name, module contents pairs+> genValidation m rs+> = header+> $$ text "module" <+> text (m ++ ".Validation") <+> text "where"+> <> newline+> $$ imports $$ validationImports m rs+> <> newline+> $$ text "validations :: Validators"+> $$ text "validations = fromList []"+++Router docs++> routerImports :: String -> [String] -> Doc+> routerImports m [] = text "import Frame.Router" $$+> text "import Frame.Model" $$+> text "import Frame.View" <> newline+> routerImports m (r:rs) = routerImports m rs $$+> text "import qualified" <+> text (m ++ ".Router." ++ r) <+> text "as" <+> text r++> routerRoutePattern :: [String] -> Doc+> routerRoutePattern [] = empty+> routerRoutePattern (p:ps) = doubleQuotes (text $ lcase p) <> text ":" <> routerRoutePattern ps++> routerRoutes :: [String] -> Doc+> routerRoutes [] = text "router _ = return Error404"+> routerRoutes (ps:rs) = text "router " <> +> parens (routerRoutePattern [ps] <> text "ps") <> +> text " = " <> text ps <> text "." <> text "index" $$ +> routerRoutes rs++> genRouter :: String -- ^ Top-level module name+> -> [String]+> -> Doc -- ^ list of module name, module contents pairs+> genRouter m rs+> = header+> $$ text "module" <+> text (m ++ ".Router") <+> text "where"+> <> newline+> $$ imports $$ routerImports m rs+> <> newline+> $$ text "router :: FrameRouter m => [String] -> m Data"+> $$ text "router " <> text "[]" <> +> text " = return $ ViewPart [paragraph $ text" <+> doubleQuotes (text "Generated index") <> text "]"+> $$ routerRoutes rs++Sub-router docs++> subRouterImports :: String -> String -> Doc+> subRouterImports m n = text "import Frame.Router" $$+> text "import Frame.View" $$+> text "import Frame.Model" <> newline $$+> text "import " <> text m <> text ".Model." <> text n $$+> text "import " <> text m <> text ".View." <> text n++> genSubRouter :: String -- ^ Top-level module name+> -> String -- ^ View name+> -> Doc -- ^ list of module name, module contents pairs+> genSubRouter m n+> = header+> $$ text "module" <+> text (m ++ ".Router." ++ n) <+> text "where"+> <> newline+> $$ imports $$ subRouterImports m n+> <> newline+> $$ text "index :: FrameRouter m => m Data"+> $$ text "index = return $ ViewPart [paragraph $ text" <+> doubleQuotes (text "Generated index for" <+> text n) <> text "]"++Model docs++> modelImports :: Doc+> modelImports = text "import Frame.Model"++> genModel :: String -- ^ Top-level module name+> -> String+> -> Doc -- ^ list of module name, module contents pairs+> genModel m n+> = header+> $$ text "module" <+> text (m ++ ".Model." ++ n) <+> text "where"+> <> newline+> $$ imports $$ modelImports++View docs++> viewImports :: Doc+> viewImports = text "import Frame.View"++> genView :: String -- ^ Top-level module name+> -> String+> -> Doc -- ^ list of module name, module contents pairs+> genView m n+> = header+> $$ text "module" <+> text (m ++ ".View." ++ n) <+> text "where"+> <> newline+> $$ imports $$ viewImports+++> withODBC :: MonadIO m => String -> (Database -> m a) -> m a+> withODBC u = (connect driver) [("DSN", u)]++> -- | Automatically creates the database modules from a db description+> genDB :: String -- ^ The name of the application e.g. ''MyApp''+> -> String -- ^ The DSN url for the database+> -> String -- ^ The name of the database to be described+> -> IO DBInfo+> genDB a u n = do+> s <- withODBC u $ \db -> dbToDBSpec True mkIdentCamelCase n db+> dbInfoToModuleFiles "" (a ++ ".DB") s+> return s++> listTables :: [TInfo] -> IO ()+> listTables [] = return ()+> listTables (TInfo{tname=n}:ts) +> = do+> putStr $ " * " ++ n ++ "\n"+> listTables ts++> findTable :: [TInfo] -> String -> Bool+> findTable [] _ = False+> findTable (TInfo{tname=tn}:ts) n +> = if n == tn then True else False++> createModule :: String -> String -> String -> IO ()+> createModule "router" n t = do+> createPath (n ++ "/Router/")+> writeFile (n ++ "/Router/" ++ t ++ ".hs") $ show $ genSubRouter n t+> return ()+> createModule "model" n t = do+> createPath (n ++ "/Model/")+> writeFile (n ++ "/Model/" ++ t ++ ".hs") $ show $ genModel n t+> return ()+> createModule "view" n t = do+> createPath (n ++ "/View/")+> writeFile (n ++ "/View/" ++ t ++ ".hs") $ show $ genView n t+> return ()+> createModule _ _ _ = return ()++> mainCreateFile :: String -> String -> DBInfo -> IO ()+> mainCreateFile mt n db = do+> case db of +> DBInfo{tbls=[]} -> do+> putStr "Perhaps you need to generate a DB first\n"+> return ()+> DBInfo{tbls=ts} -> do+> putStr $ "Which table would you like to create a " ++ mt ++ " for?\n"+> listTables ts+> putStr "\n b) Back\n\n"+> t <- getLine+> putStr "\n"+> case t == "b" || findTable ts t of+> True -> createModule mt n t+> False -> do+> putStr "Could not find that table\n\n"+> mainCreateFile mt n db++> tName :: TInfo -> String+> tName TInfo{tname=n} = n++> appM :: (String -> IO ()) -> [String] -> IO ()+> appM _ [] = return ()+> appM mf (a:as) = do+> mf a+> appM mf as+> return ()++> gen :: String -> String -> String -> IO ()+> gen n du dn = do +> db <- genDB n du dn +> case db of +> DBInfo{tbls=[]} -> do+> putStr "No tables were found\n"+> return ()+> DBInfo{tbls=ts} -> do+> cd <- getCurrentDirectory+> createPath (n ++ "/Sessions/")+> writeFile (n ++ "/Config.hs") $ show $ genConfig n du dn $ cd ++ "/" ++ n+> writeFile (n ++ "/Validation.hs") $ show $ genValidation n $ map tName ts+> appM (createModule "model" n) $ map tName ts+> appM (createModule "view" n) $ map tName ts+> appM (createModule "router" n) $ map tName ts+> writeFile (n ++ "/Router.hs") $ show $ genRouter n $ map tName ts+> writeFile (n ++ "/Main.hs") $ show $ genMain n+> return ()++> helpText :: String+> helpText = "Usage: frame-gen APPNAME DBURL DBNAME\n"++> main :: IO ()+> main = do+> as <- getArgs+> case length as == 3 of+> True -> gen (as!!0) (as!!1) (as!!2)+> False -> do +> putStr helpText+> return ()++> -- From DBSpecToDBDirect+> createPath :: FilePath -> IO ()+> createPath p | "/" `isPrefixOf` p = createPath' "/" (dropWhile (=='/') p)+> | otherwise = createPath' "" p+> where+> createPath' _ "" = return ()+> createPath' b p = do+> let (d,r) = break (=='/') p+> n = withPrefix b d+> createDirIfNotExists n+> createPath' n (dropWhile (=='/') r)++> createDirIfNotExists :: FilePath -> IO ()+> createDirIfNotExists p = do+> exists <- doesDirectoryExist p+> unless exists (createDirectory p)+++> withPrefix :: FilePath -> String -> FilePath+> withPrefix base f | null base = f+> | otherwise = base ++ "/" ++ f
+ src/Frame/State.lhs view
@@ -0,0 +1,140 @@+> {-|+> The state contains mutable environmental variables such as posted form fields,+> field validators and the session+> -}+> module Frame.State (+> Vars (..),+> FrameState,+> FrameReader,+> get,+> put,+> gets,+> startState,+> setPost,+> getField,+> putFields,+> mergeFields,+> putField,+> delField,+> -- * Validators+> getValidator,+> putValidators,+> putValidator+> ) where++> import Prelude hiding (lookup)+> import Data.Map+> import qualified Control.Monad.State as S (gets, get, put)+> import Control.Monad.State hiding (gets, get, put)++> import Frame.Config+> import Frame.Types+> import Frame.Validation++> -- | The state record+> data Vars = Vars { +> fields :: Fields -- ^ Posted fields+> , validators :: Validators -- ^ Field validation functions+> , post :: Bool -- ^ Has a form been posted?+> , session :: Fields -- ^ Session fields+> , ajax :: Bool -- ^ Is this an AJAX request?+> }++> class (Monad m) => MonadStateGet s m | m -> s where+> -- | Provides get access to the state, mirroring Control.Monad.State.get+> get :: m s+> instance (Monad m) => MonadStateGet s (StateT s m) where+> get = S.get++> class (Monad m) => MonadStatePut s m | m -> s where+> -- | Provides get access to the state, mirroring Control.Monad.State.put+> put :: s -> m ()+> instance (Monad m) => MonadStatePut s (StateT s m) where+> put = S.put++> -- | Gets a specific component from the state, using the supplied projection function+> gets :: (MonadStateGet s m) => (s -> a) -- ^ State projection function+> -> m a -- ^ Projected component+> gets f = do+> s <- get+> return (f s)++> class (MonadStateGet Vars m, MonadStatePut Vars m) => FrameState m+> instance (MonadStateGet Vars m, MonadStatePut Vars m) => FrameState m++> class (MonadStateGet Vars m) => FrameReader m+> instance (MonadStateGet Vars m) => FrameReader m++> -- | A default empty start state+> startState :: Vars+> startState = Vars {fields = empty, validators = empty, post = False, session = empty, ajax = False}++> setPost :: FrameState m => Bool -> m ()+> setPost b = do+> v <- get+> put v {post=b}++> -- | Looks up a specific field in the state by the given field name+> getField :: FrameReader m => FieldName -- ^ FieldName to be looked up+> -> m (Maybe WrapperType) -- ^ The field (if found)+> getField fn = do+> fs <- gets fields+> return $ lookup fn fs++> -- | Deletes a specific field in the state by the given field name+> delField :: FrameState m +> => FieldName -- ^ FieldName to be deleted+> -> m ()+> delField fn = do+> fs <- gets fields+> v <- get+> put v {fields=delete fn fs}++> -- | Replaces the fields in the state+> putFields :: FrameState m => Fields -- ^ Fields to replace with+> -> m () -- ^ Nothing (but the modified state) is returned+> putFields fs = do +> v <- get+> put v {fields=fs}++> -- | Merges the given fields with the existing state (existing state fields are favoured)+> mergeFields :: FrameState m => Maybe Fields -- ^ Fields to merge+> -> m () -- ^ Nothing (but the modified state) is returned+> mergeFields Nothing = return ()+> mergeFields (Just fs') = do+> fs <- gets fields+> putFields $ union fs fs'++> -- | Associate a value with a FieldName in the state+> putField :: (FrameState m, FrameConfig m, Wrappable a) +> => FieldName -- ^ The FieldName of the field being updated+> -> a -- ^ The (wrappable) field to update state with+> -> m () -- ^ Nothing (but the modified state) is returned+> putField fn f = do+> db <- asks database+> fs <- gets fields+> v <- get+> put v {fields=insert fn (wrap db fn f) fs}++> -- | Look up validators functions for a particular field+> getValidator :: FrameReader m => FieldName -- ^ Validators to look up+> -> m (Maybe [WrapperType -> Maybe String]) -- ^ The validator functions (if found)+> getValidator fn = do+> vs <- gets validators+> return $ lookup fn vs++> -- | Replaces the Validators in the state+> putValidators :: FrameState m => Validators -- ^ Validators to replace with+> -> m () -- ^ Nothing (but the modified state) is returned+> putValidators vs = do+> v <- get+> put v {validators=vs}++> -- | Associate a set of validator functions with a FieldName in the state+> putValidator :: FrameState m => FieldName -- ^ The FieldName of the validator being updated+> -> [WrapperType -> Maybe String] -- ^ The validator functions to update state with+> -> m () -- ^ Nothing (but the modified state) is returned+> putValidator fn ms = do+> vs <- gets validators+> v <- get+> put v {validators=insert fn ms vs}
+ src/Frame/Types.lhs view
@@ -0,0 +1,280 @@+> {-|+> Defines a homogenous collection of field types to interface typeless+> HTTP and HTML with the application and with HaskellDB+> -}+> module Frame.Types (+> module Database.HaskellDB.FieldType,+> FieldName,+> WrapperType (..),+> Fields,+> showField,+> purge,+> Wrappable (..),+> wrapInt,+> wrapBool,+> wrapError,+> isMandatory,+> maybeUnwrap,+> fromList',+> unwrapField+> ) where++> import Prelude hiding (lookup)+> import Data.Map hiding (map)+> import Database.HaskellDB.BoundedList+> import Database.HaskellDB.DBLayout+> import Database.HaskellDB.FieldType+> import Data.Binary+> import Data.Maybe+> import Control.Monad++> import Frame.Utilities++> -- | Label for a specific field+> type FieldName = String++> -- | Collection of heterogenous fields associated by 'FieldName'+> type Fields = Map FieldName WrapperType++> -- | Casts the 'FieldName' in fields to string+> showField :: FieldName -- ^ Field name to look up+> -> Fields -- ^ Fields to look in+> -> String -- ^ String representation of field to return+> showField fn fs = case lookup fn fs of+> Nothing -> ""+> Just w -> show w++> purge' :: DBInfo+> -> FieldName +> -> WrapperType+> -> Bool+> purge' _ fn (WrapEmpty (BStrT _)) = True+> purge' db fn (WrapEmpty _) = case isMandatory db fn of+> (Just b) -> not b+> Nothing -> True+> purge' db _ _ = True++> -- | Purge non mandatory empty fields +> purge :: DBInfo+> -> Fields -- ^ Fields to purge+> -> Fields -- ^ Purged fields+> purge db = filterWithKey (purge' db)++> lookupFD' :: DBInfo -> String -> String -> Maybe FieldDesc+> lookupFD' DBInfo {tbls = []} t _ = Nothing+> lookupFD' d@DBInfo {tbls = (TInfo {tname = n, cols = cs}:ts)} t c = if n == t then lookupFD'' cs c else lookupFD' d {tbls = ts} t c++> lookupFD'' :: [CInfo] +> -> String +> -> Maybe FieldDesc +> lookupFD'' [] c = Nothing+> lookupFD'' (CInfo {cname=n, descr=d}:cs) c = if n == c then Just d else lookupFD'' cs c++> -- | Find a FieldDesc(ription) of a particular FieldName+> lookupFD :: DBInfo -- ^ Database description being searched+> -> FieldName -- ^ Field name being looked up+> -> Maybe FieldDesc -- ^ Description of field found+> lookupFD db fn = let (l, fns) = explodeFieldName fn in+> if l /= 2 then Nothing else +> lookupFD' db (head fns) (head $ tail fns)++> lookupT :: DBInfo+> -> FieldName+> -> Maybe FieldType+> lookupT db fn = liftM fst $ lookupFD db fn++> lookupM :: DBInfo+> -> FieldName+> -> Maybe Bool+> lookupM db fn = liftM snd $ lookupFD db fn++> -- | Heterogeneous type wrapper+> data WrapperType+> = WrapString (Maybe Int) String -- ^ String wrapper+> | WrapInt Int -- ^ Int wrappr+> | WrapBool Bool -- ^ Bool wrapper+> | WrapError FieldType String -- ^ Type error (specific case of error)+> | WrapEmpty FieldType -- ^ Empty type++> instance Show WrapperType where+> show (WrapString _ s) = s+> show (WrapInt i) = show i+> show (WrapBool b) = show b+> show (WrapError _ s) = s+> show (WrapEmpty _) = ""++> isMandatory :: DBInfo -> FieldName -> Maybe Bool+> isMandatory = lookupM++> class Wrappable a where+> -- | Function to wrap a value associated with a given 'FieldName'+> wrap :: DBInfo -- ^ The database to check for the type+> -> FieldName -- ^ Field name that represents this value+> -> a -- ^ The value in question+> -> WrapperType -- ^ The wrapped value+>+> -- | Function to unwrap a 'WrapperType' to its original type+> unwrap :: WrapperType -- ^ The wrapped type+> -> a -- ^ The originally typed value++> instance Wrappable Int where+> wrap db fn i = wrap db fn (show i) +> unwrap (WrapInt i) = i+> unwrap (WrapEmpty _) = 0+> unwrap (WrapString _ s) = read s+> unwrap (WrapBool False) = 0+> unwrap (WrapBool True) = 1+> unwrap _ = error "Not an Int"++> instance Wrappable WrapperType where+> wrap _ _ w = w+> unwrap w = w++> instance Wrappable [Char] where+> wrap db fn s = let t = lookupT db fn in+> wrap' s t+> unwrap (WrapString _ s) = s+> unwrap (WrapEmpty _) = ""+> unwrap (WrapInt i) = show i+> unwrap (WrapBool b) = show b+> unwrap _ = "Error in unwrapping potential String"++> instance Wrappable Bool where+> wrap db fn b = wrap db fn (show b)+> unwrap (WrapBool b) = b+> unwrap (WrapEmpty b) = False+> unwrap (WrapString _ "False") = False+> unwrap (WrapString _ "True") = True+> unwrap (WrapInt 0) = False+> unwrap (WrapInt 1) = True+> unwrap _ = error "Not an Bool"++> instance Size n => Wrappable (BoundedList Char n) where+> wrap db fn bs = wrap db fn $ fromBounded bs+> unwrap w = trunc $ unwrap w++> instance Show a => Wrappable (Maybe a) where+> wrap db fn (Just a) = wrap db fn $ show a +> wrap _ _ Nothing = WrapEmpty IntT+> unwrap _ = Nothing++> -- | Wrap a 'String' representation of an 'Int'+> wrapInt :: String -- 'String' to be wrapped+> -> WrapperType -- The wrapped 'Int' (unless empty/error)+> wrapInt v = wrapInt' v $ reads v++> wrapInt' :: String+> -> [(Int, String)]+> -> WrapperType +> wrapInt' _ ((v,""):ts) = WrapInt v+> wrapInt' "" _ = WrapEmpty IntT+> wrapInt' v ((_,_):ts) = WrapError IntT v+> wrapInt' v [] = WrapError IntT v++> -- | Wrap a 'String' representation of a 'Bool'+> wrapBool :: String -- 'String' to be wrapped+> -> WrapperType -- The wrapped 'Bool' (unless empty/error)+> wrapBool v = wrapBool' v $ reads v ++> wrapBool' :: String+> -> [(Bool, String)]+> -> WrapperType +> wrapBool' _ ((v,""):ts) = WrapBool v+> wrapBool' "" _ = WrapEmpty BoolT+> wrapBool' v ((_,_):ts) = WrapError BoolT v+> wrapBool' v [] = WrapError BoolT v++> -- | Returns an error message if there has been a wrapping error+> wrapError :: WrapperType -- ^ The wrapped type to check+> -> String -- ^ Error message+> wrapError (WrapError IntT _) = "Needs to be a number"+> wrapError (WrapError BoolT _) = "Needs to be a boolean" +> wrapError (WrapError (BStrT _) _) = "Could not wrap" ++> wrap' :: String+> -> Maybe FieldType+> -> WrapperType+> wrap' v (Just IntT) = wrapInt v+> wrap' v (Just (BStrT l)) = WrapString (Just l) v+> wrap' v (Just BoolT) = wrapBool v+> wrap' "" (Just t) = WrapEmpty t+> wrap' "" Nothing = WrapEmpty $ BStrT 0+> wrap' v (Just t) = WrapError t v+> wrap' v Nothing = WrapError (BStrT $ length v) v++> -- | A potential 'WrapperType' is 'WrapEmpty' if 'Nothing'+> maybeUnwrap :: Maybe WrapperType -- ^ The potential wrapped type+> -> WrapperType -- ^ Definitely a wrapped type (though perhaps an empty one)+> maybeUnwrap (Just t) = t+> maybeUnwrap Nothing = WrapEmpty $ BStrT 0++> -- | Special version of 'Data.Map.fromList' that also wraps fields as it goes+> fromList' :: DBInfo -- ^ Database to use for wrapping info+> -> [(FieldName, String)] -- ^ List of pairs associating a field name to some 'String' representation of a value +> -> Map FieldName WrapperType -- ^ The map associating field names to wrapped types+> fromList' db is = fromList $ map (\x -> let fx = fst x in (fx, wrap db fx $ snd x)) is++> unwrapField :: Wrappable a => FieldName -> Fields -> Maybe a+> unwrapField fn fs = appMaybe unwrap $ lookup fn fs ++> instance Binary FieldType where+> put StringT = putWord8 0+> put IntT = putWord8 1+> put IntegerT = putWord8 2+> put DoubleT = putWord8 3+> put BoolT = putWord8 4+> put CalendarTimeT = putWord8 5+> put (BStrT i) = do+> putWord8 6+> put i+> get = do+> tag <- getWord8+> case tag of+> 0 -> return StringT+> 1 -> return IntT+> 2 -> return IntegerT+> 3 -> return DoubleT+> 4 -> return BoolT+> 5 -> return CalendarTimeT+> 6 -> do+> i <- get+> return $ BStrT i++> instance Binary WrapperType where+> put (WrapString mi s) = do +> putWord8 0 +> put mi+> put s+> put (WrapInt i) = do+> putWord8 1+> put i+> put (WrapBool b) = do+> putWord8 2+> put b+> put (WrapError t s) = do+> putWord8 3+> put t+> put s+> put (WrapEmpty t) = do+> putWord8 4+> put t+> get = do+> tag <- getWord8+> case tag of+> 0 -> do+> mi <- get+> s <- get+> return $ WrapString mi s+> 1 -> do+> i <- get+> return $ WrapInt i+> 2 -> do+> b <- get+> return $ WrapBool b+> 3 -> do+> t <- get+> s <- get+> return $ WrapError t s+> 4 -> do+> t <- get+> return $ WrapEmpty t
+ src/Frame/Utilities.lhs view
@@ -0,0 +1,136 @@+> -- | Common helper functions+> module Frame.Utilities ( +> -- * String helpers+> explode,+> explodeURL,+> explodeFieldName,+> implode,+> implodeUrl,+> humanise,+> humaniseCamel,+> humaniseUrl,+> humanisePath,+> -- * Maybe helpers+> maybeMaybe,+> headMaybe,+> pop,+> appMaybe,+> allNothing,+> -- * Failure helpers+> (?),+> (??),+> module Data.Map,+> module Data.Maybe+> ) where++> import Data.Map (Map, empty, fromList)+> import Data.Maybe+> import Data.Char++> -- | Similar to 'Prelude.words' except splitting against arbitrary 'Char'+> explode :: Char -- ^ The character to split against+> -> String -- ^ The string to split+> -> [String] -- ^ The resultant list+> explode c s = case dropWhile (==c) s of+> "" -> []+> s' -> w : explode c s''+> where (w, s'') = break (==c) s'++> -- | Explode for URLs+> explodeURL :: String -> [String]+> explodeURL = explode '/'++> -- | Explode for field names+> explodeFieldName :: String -- ^ The 'FieldName'+> -> (Int, [String]) -- ^ (Length of the list, Resultant list)+> explodeFieldName fn = let fns = explode '.' fn in+> (length fns, fns)++> -- | Opposite of explode+> implode :: Char -> [String] -> String+> implode _ [] = ""+> implode _ [w] = w+> implode c (w:ws) = w ++ c : implode c ws++> -- | Implode for URLs+> implodeUrl :: [String] -> String+> implodeUrl ws = implode '/' ws++> -- | 'Maybe' 'Maybe' == 'Maybe' +> maybeMaybe :: Maybe (Maybe a) -> Maybe a+> maybeMaybe (Just ma) = ma+> maybeMaybe Nothing = Nothing++> -- | Safe head+> headMaybe :: [a] -> Maybe a+> headMaybe [] = Nothing+> headMaybe (a:_) = Just a ++> -- | Function application within 'Maybe'+> appMaybe :: (a -> b) -> Maybe a -> Maybe b+> appMaybe f Nothing = Nothing+> appMaybe f (Just a) = Just $ f a++> -- | Monadic safe head+> pop :: (Monad m) => m [a] -> m (Maybe a)+> pop s = do s' <- s+> return $ headMaybe s'++> -- | List of 'Nothing' == True+> allNothing :: [Maybe a] -> Bool+> allNothing [] = True+> allNothing (Nothing:ns) = allNothing ns+> allNothing (Just _:ns) = False++> -- | Cast maybe to string (with 'Nothing' == '''')+> showMaybeString :: Maybe String -> String+> showMaybeString (Just s) = s+> showMaybeString Nothing = ""++> -- | ''camelCase'' to ''Camel Case''+> humaniseCamel :: String -> String+> humaniseCamel [] = "" +> humaniseCamel (s:ss) = (toUpper s):humaniseCamel' ss++> humaniseCamel' :: String -> String+> humaniseCamel' [] = "" +> humaniseCamel' (s:ss) = if isUpper s then ' ':s:humaniseCamel' ss else s:humaniseCamel' ss++> -- | ''hi there'' to ''Hi There''+> humanise :: String -> String+> humanise = humaniseGen ' ' ' '++> humaniseGen :: Char -> Char -> String -> String+> humaniseGen e i = implode i . humaniseGen' . explode e++> humaniseGen' :: [String] -> [String]+> humaniseGen' [] = []+> humaniseGen' ((h:ts):ws) = ((toUpper h):ts):humaniseGen' ws++> -- | ''/a/url'' to ''A Url''+> humaniseUrl :: String -> String -> String+> humaniseUrl "" d = d+> humaniseUrl "/" d = d+> humaniseUrl u _ = humaniseGen '/' '/' $ humaniseGen '_' ' ' u++> -- | \[''a'', ''url''\] to ''A Url''+> humanisePath :: [String] -> String -> String+> humanisePath u d = humaniseUrl (implodeUrl u) d++? offers a way to catch validation failures++> infix 3 ?++> -- | Captures failure+> (?) :: Bool -- ^ Test+> -> String -- ^ String on failure+> -> Maybe String -- ^ Nothing if success, (Just ''message'') on success+> False ? s = Just s+> True ? _ = Nothing+++> infix 3 ??++> -- | Same as (?), always returns a string ('''' on success)+> (??) :: Bool -> String -> String+> b ?? s = showMaybeString $ b ? s
+ src/Frame/Validation.lhs view
@@ -0,0 +1,85 @@+> -- | Functions for validation of fields+> module Frame.Validation (+> Validators,+> -- * Helper methods+> validate,+> validateField,+> allValidated,+> -- * Validation functions+> notEmpty,+> shorterThan,+> greaterThan,+> withinBounds+> ) where++> import Database.HaskellDB.DBLayout+> import qualified Data.Map as Map++> import Frame.Utilities+> import Frame.Types++> {-| +> A validator is a map associating field names to a list of functions taking a+> wrapped type to a potential (error) string+> -}+> type Validators = Map FieldName [WrapperType -> Maybe String]++> -- | Type validation functions+> typeValidations :: WrapperType -- ^ The wrapped type to validate+> -> [WrapperType -> Maybe String] -- ^ The functions to validate that type+> typeValidations (WrapString _ _) = [withinBounds]+> typeValidations w@(WrapError _ _) = [\x -> Just $ wrapError w] -- Constant failure+> typeValidations _ = []++> -- | Validate a particular field against a list of validators+> validateField :: [WrapperType -> Maybe String] -> WrapperType -> [Maybe String]+> validateField fs t = map (\f -> f t) (fs ++ typeValidations t)++> validateField' :: Validators -> FieldName -> WrapperType -> [Maybe String]+> validateField' vs fn t = case Map.lookup fn vs of+> Just fs -> validateField fs t+> Nothing -> []++> -- | Validate a whole set of fields against a set of validators+> validate :: Validators -> Fields -> Map.Map FieldName [Maybe String]+> validate vs = Map.mapWithKey (validateField' vs)++> maybeAnd :: [Maybe String] -> Bool+> maybeAnd ms = and $ Prelude.map isNothing ms++> validated :: Map.Map FieldName [Maybe String] -> Map.Map FieldName Bool+> validated = Map.map maybeAnd++> -- | True if all fields validate against a set of validators+> allValidated :: Validators -> Fields -> Bool+> allValidated vs fs = and $ Map.elems $ validated $ validate vs fs++> -- | Cannot be empty+> notEmpty :: WrapperType -- ^ The wrapped value to check+> -> Maybe String -- ^ Nothing if it's not empty, otherwise an error message+> notEmpty (WrapString _ s) = s /= "" ? "Cannot be empty"+> notEmpty (WrapEmpty _) = notEmpty (WrapString Nothing "")+> notEmpty (WrapError _ s) = notEmpty (WrapString Nothing s)+> notEmpty _ = Nothing++> -- | Must be shorter than a given length+> shorterThan :: Int -- ^ Length to be shorter than+> -> WrapperType -- ^ The wrapped value to check+> -> Maybe String -- ^ Nothing if it's shorter, otherwise an error message+> shorterThan n (WrapString _ s) = length s < n ? "Must be under " ++ show n ++ " characters long"+> shorterThan n (WrapEmpty _) = shorterThan n (WrapString Nothing "")+> shorterThan n (WrapError _ s) = shorterThan n (WrapString Nothing s)+> shorterThan _ _ = Nothing++> -- | Must be greater than a given number+> greaterThan :: Int -- ^ Number to be greater than+> -> WrapperType -- ^ The wrapped value to check+> -> Maybe String -- ^ Nothing if it's greater, otherwise an error+> greaterThan x (WrapInt y) = y > x ? "Must be over " ++ show x +> greaterThan _ _ = Nothing++> -- | A type level check to make sure a string is within the bounds defined+> withinBounds :: WrapperType -- ^ The wrapped type to check+> -> Maybe String -- ^ Nothing if it's within bounds, otherwise an error+> withinBounds (WrapString (Just n) s) = length s <= n ? "Must be " ++ show n ++ " characters or less long"+> withinBounds _ = Nothing
+ src/Frame/View.lhs view
@@ -0,0 +1,165 @@+> -- | High level view helpers+> module Frame.View (+> module Frame.GUI,+> module Frame.Data,+> module Database.HaskellDB.BoundedList,+> FrameView,+> -- *** General,+> (-.-),+> title,+> list,+> errorList,+> text,+> link,+> -- *** Forms+> formGen,+> form,+> formField,+> submitButton,+> deleteLink,+> cancelLink,+> paragraph+> ) where++> import Database.HaskellDB.BoundedList+> import Database.HaskellDB.DBLayout hiding (fieldName)++> import Frame.Model+> import Frame.State+> import Frame.Config+> import Frame.GUI+> import Frame.Data+> import Frame.Types+> import Frame.Validation+> import Frame.Utilities++> class (FrameConfig m, FrameReader m) => FrameView m+> instance (FrameConfig m, FrameReader m) => FrameView m++> -- | Helper function for a submit button+> submitButton :: FormElement+> submitButton = Button "submit" $ WrapString Nothing "Submit"++> -- | Helper function for a delete link+> deleteLink :: URL -- ^ Route for deletion+> -> FormElement+> deleteLink u = ButtonLink "Delete" u++> -- | Helper function for a cancel link+> cancelLink :: URL -- ^ Route for cancelation+> -> FormElement+> cancelLink u = ButtonLink "Cancel" u++> -- | Helper function to create a single simple element paragraph+> paragraph :: Element -- ^ Element+> -> Container -- ^ Paragraph+> paragraph e = Paragraph [e] []++> singleton :: a -> [a]+> singleton l = [l]++> -- | Abstract list generator+> list :: (a -> Container) -- ^ List item generator+> -> [a] -- ^ Items+> -> [Class] -- ^ Classes+> -> Container -- ^ List+> list f as cs = List (map (singleton . f) as) cs++> -- | Creates element level text+> text :: String -- ^ Text to use+> -> Element -- ^ Element created+> text s = Element $ Text s++> -- | Creates a link with just a text element+> link :: URL -- ^ URL to use+> -> String -- ^ Text to use+> -> Element -- ^ The link+> link u s = Link u $ Text s++> -- | Helper function for generating a potential error list+> errorList :: [String] -- ^ Errors+> -> Maybe Container -- ^ Error list (if errors)+> errorList [] = Nothing+> errorList es = Just $ list (\e -> paragraph $ text e) es ["error"]++> -- | Helper function for creating a form field+> formField :: FieldName +> -> Label+> -> FormValue -- ^ Set value of field+> -> Maybe Int -- ^ Potential length restriction of the field+> -> [String] -- ^ List of errors+> -> Bool -- ^ Is the form field hidden?+> -> FormElement -- ^ The field+> formField fn f v ml@(Just l) es False = if l <= 255 then TextField fn f v ml $ errorList es else TextArea fn f v $ errorList es+> formField fn f v Nothing es False = TextField fn f v Nothing $ errorList es+> formField fn f v _ _ True = HiddenField fn v++> -- | Helper function to create a simple form with a single group+> form :: Label -- ^ Group label+> -> [FormElement] -- ^ Form elements+> -> [String] -- ^ Any classes+> -> Container -- ^ The form+> form l es cs = Form [+> FormGroup es l+> ] cs++> -- | Generates a form based on a database description+> formGen :: FrameView m => (Table r) -- ^ The table for which the form will be gotten+> -> [FormElement] -- ^ A set of form elements to append to the form+> -> [String] -- ^ A set of form fields to hide/not display+> -> m Container -- ^ The form+> formGen t es hs = do +> db <- asks database+> n <- asks dbName+> formGen' es hs n (tableName t) db++> formGen' :: FrameView m => [FormElement] -> [String] -> String -> String -> DBInfo -> m Container+> formGen' es hs d t (DBInfo {dbname=n, tbls=ts}) +> = if (d == n) then +> formGenTbl es hs d t ts +> else +> return $ paragraph $ text "Database not found"++> formGenTbl :: FrameView m => [FormElement] -> [String] -> String -> String -> [TInfo] -> m Container+> formGenTbl es hs d t [] = return $ paragraph $ text "Table not found"+> formGenTbl es hs d t ((TInfo {tname=tn, cols=cs}):ts) +> = if (t == tn) then +> do +> cs <- formGenCol hs d t cs+> return $ form t (cs ++ es) [t]+> else +> formGenTbl es hs d t ts++> formGenCol :: FrameView m => [String] -> String -> String -> [CInfo] -> m [FormElement]+> formGenCol hs d t [] = return []+> formGenCol hs d t ((CInfo {cname=n, descr=(ty,_)}):cs') = do +> cs <- formGenCol hs d t cs'+> mf <- getField $ fieldName t n+> mv <- getValidator $ fieldName t n+> case mf of+> Just f -> return $ (formField (fieldName t n) (humaniseCamel n) f (maxLen ty) (errors mv f) $ hide n):cs +> Nothing -> return $ if hide n then cs else (formField (fieldName t n) (humaniseCamel n) (WrapEmpty StringT) (maxLen ty) [] False):cs+> where+> errors (Just v) f = map fromJust $ filter isJust $ validateField v f+> errors Nothing _ = []+> maxLen (BStrT n) = Just n+> maxLen _ = Nothing+> hide n = elem (fieldName t n) $ (fieldName t "id"):hs++> -- | The 'title' function wraps a ViewPart in a View if not an Ajax request+> title :: FrameView m +> => String -- ^ The title of the View+> -> m Data -- ^ The ViewPart to wrap+> -> m Data -- ^ The resulting Data type+> title t d = do +> a <- gets ajax+> c <- asks css+> case a of+> True -> d+> False -> do +> d' <- d+> return $ title' t c d'++> title' :: String -> [String] -> Data -> Data+> title' t c (ViewPart cs) = View $ Frame t c cs+> title' _ _ d = d