diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runghc + +import Distribution.Simple +main = defaultMain diff --git a/frame.cabal b/frame.cabal new file mode 100644 --- /dev/null +++ b/frame.cabal @@ -0,0 +1,60 @@ +Name: frame +Version: 0.1 +Cabal-version: >= 1.2 +Build-type: Simple +Copyright: Adam Dunkley +Maintainer: "Adam Dunkley" +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 diff --git a/src/Frame.lhs b/src/Frame.lhs new file mode 100644 --- /dev/null +++ b/src/Frame.lhs @@ -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 ((-.-)) diff --git a/src/Frame/Config.lhs b/src/Frame/Config.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Config.lhs @@ -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 diff --git a/src/Frame/Data.lhs b/src/Frame/Data.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Data.lhs @@ -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 diff --git a/src/Frame/GUI.lhs b/src/Frame/GUI.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/GUI.lhs @@ -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) = "\n\t\n\t\t" ++ +> t ++ "\n\t" ++ showCSS s ++ "\n" ++ +> concatMap show cs ++ +> "\n\t\n" + +> showCSS :: [String] -> String +> showCSS [] = "" +> showCSS (c:cs) = "\n\t\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) = "" ++ concatMap show cs ++ "" +> show (Paragraph es c) = "" ++ concatMap show es ++ "

" +> show (Code s) = "" ++ s ++ "" +> show (Quote cs) = "
" ++ concatMap show cs ++ "
" +> show (Header s es) = "" ++ concatMap show es ++ "" +> show (List is c) = "" ++ concatMap showListItem is ++ "" +> show (NumList is c) = "" ++ concatMap showListItem is ++ "" +> show (Form fs c) = "" ++ concatMap show fs ++ "" +> show (Error s) = "
" ++ concatMap show s ++ "
" +> show Line = "
" +> 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
  • " ++ concatMap show cs ++ "
    • " + +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) = "" ++ show e ++ "" +> show (Strong es) = "" ++ concatMap show es ++ "" +> show (Emphasis es) = "" ++ concatMap show es ++ "" +> show (Element e) = show e +> show Break = "
    " + +> data Element' +> = Text String -- ^ Textual element +> | Image URL String -- ^ Image element + +> instance Show Element' where +> show (Image u 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) = "
    " ++ ((length l == 0) ?? ("" ++ l ++ "")) ++ "
      " ++ concatMap show es ++ "
    " +> show (TextField fn l fv ml (Just e)) = "
  • " ++ show e ++ "
    • " +> show (TextField fn l fv ml Nothing) = "
    • " +> show (HiddenField l fv) = "" +> show (TextArea l t fv (Just e)) = "
  • " ++ show e ++ "
    • " +> show (TextArea l t fv Nothing) = "
    • " +> show (Button l fv) = "
    • " +> show (ButtonLink l u) = "
  • " ++ l ++ "
    • " + +> showMaxLength :: Maybe Int -> String +> showMaxLength (Just i) = " maxlength=\"" ++ show i ++ "\"" +> showMaxLength Nothing = "" + +> -- | Form values are just wrapped types +> type FormValue = WrapperType diff --git a/src/Frame/Model.lhs b/src/Frame/Model.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Model.lhs @@ -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) diff --git a/src/Frame/Router.lhs b/src/Frame/Router.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Router.lhs @@ -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 diff --git a/src/Frame/Server.lhs b/src/Frame/Server.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Server.lhs @@ -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 diff --git a/src/Frame/Session.lhs b/src/Frame/Session.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Session.lhs @@ -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 diff --git a/src/Frame/Shell.lhs b/src/Frame/Shell.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Shell.lhs @@ -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 diff --git a/src/Frame/State.lhs b/src/Frame/State.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/State.lhs @@ -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} diff --git a/src/Frame/Types.lhs b/src/Frame/Types.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Types.lhs @@ -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 diff --git a/src/Frame/Utilities.lhs b/src/Frame/Utilities.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Utilities.lhs @@ -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 diff --git a/src/Frame/Validation.lhs b/src/Frame/Validation.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/Validation.lhs @@ -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 diff --git a/src/Frame/View.lhs b/src/Frame/View.lhs new file mode 100644 --- /dev/null +++ b/src/Frame/View.lhs @@ -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