diff --git a/Blog/Extensions/FormProcessors.hs b/Blog/Extensions/FormProcessors.hs index 0ecee79..90678b4 100644 --- a/Blog/Extensions/FormProcessors.hs +++ b/Blog/Extensions/FormProcessors.hs @@ -7,5 +7,5 @@ import Framework.Modules.TextCaptcha.FormProcessors -- | These functions may modify each Form. formProcessors :: FormsPlugins -formProcessors = [addCaptcha ["comment"]] +formProcessors = [addCaptcha ["commentform"]] diff --git a/Blog/Models.hs b/Blog/Models.hs index de200d8..363f86a 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -9,6 +9,7 @@ import Framework.Types import Framework.Forms.Types import Framework.Forms.HTML import Framework.Forms.Validators +import Framework.Forms.ModelForm import Framework.ORM import Framework.Modules.Formatters.Markdown @@ -17,8 +18,8 @@ postModel = emptyModel { mTable = "posts", mFields = ["id" ::: PrimaryKey, "dt" ::: CurrentDateColumn, - "title" ::: StringColumn, - "body" ::: StringColumn], + ("title" ::: StringColumn) `ValidateBy` notEmpty, + ("body" ::: StringColumn) `ValidateBy` notEmpty `UsingWidget` textarea], mCached = ["ncomments" ::: IntegerColumn], defaultOrdering = [Desceding "dt"], perPage = Just 5 @@ -35,12 +36,14 @@ postmarkdown = markdown2html . (transformString 3 id) -- tracelines x = unlines $ zipWith trace (map (("^"++).(++"$")) $ lines x) (lines x) -postForm = Form { - formName = "postform", - formModel = postModel, - fFields = [ Field "title" "" inputbox noValidate, - Field "body" "" textarea notEmpty] - } +-- postForm = Form { +-- formName = "postform", +-- formModel = postModel, +-- fFields = [ Field "title" "" inputbox noValidate, +-- Field "body" "" textarea notEmpty] +-- } + +postForm = modelForm postModel addNComments post n = setCached postModel "ncomments" IntegerColumn n @@ -53,7 +56,7 @@ commentModel = emptyModel { "pid" ::: ForeignKey postModel "id", "dt" ::: CurrentDateColumn, "author" ::: StringColumn, - "body" ::: StringColumn ], + ("body" ::: StringColumn) `ValidateBy` notEmpty `UsingWidget` textarea ], mCached = [], defaultOrdering = [Asceding "dt"] } @@ -64,12 +67,13 @@ commentDate = transformString 1 id author = transformString 2 id commentBody = transformString 3 id -commentForm = Form { - formName = "comment", - formModel = commentModel, - fFields = [ Field "author" "" inputbox noValidate, - Field "body" "" textarea notEmpty] - } +-- commentForm = Form { +-- formName = "comment", +-- formModel = commentModel, +-- fFields = [ Field "author" "" inputbox noValidate, +-- Field "body" "" textarea notEmpty] +-- } +commentForm = modelForm commentModel ------------------------------------------------------------------------------- diff --git a/Framework/Forms/HTMLTypes.hs b/Framework/Forms/HTMLTypes.hs new file mode 100644 index 0000000..a9b1ec9 --- /dev/null +++ b/Framework/Forms/HTMLTypes.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies #-} +module Framework.Forms.HTMLTypes where + +import Framework.Types + +data HTMLTag = Tag { + tagName :: String, + tagAttrs :: [FormVar], + tagContent :: HTML, + mayCollapse :: Bool -- ^ May we collapse <tag></tag> to <tag/> ? + } + | Text String + +type HTML = [HTMLTag] + +-- | Types of this class represent HTML widgets +class Widget w where + -- | Type of widget content; not used at the moment. + type WContent w + -- | Generate HTML for widget + html :: w -- ^ A widget + -> String -- ^ Widget's html \"name\" attribute + -> String -- ^ Value of widget + -> HTMLTag + -- | Read widget's value from string. Not used yet. + wRead :: String -> WContent w diff --git a/Framework/Forms/ModelForm.hs b/Framework/Forms/ModelForm.hs new file mode 100644 index 0000000..84f1765 --- /dev/null +++ b/Framework/Forms/ModelForm.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts, ExistentialQuantification, RankNTypes #-} +module Framework.Forms.ModelForm + (modelForm, + addFields + ) where + +import Framework.Forms.Types +import Framework.Forms.Validators +import Framework.Forms.HTML +import Framework.ORM + +modelForm :: Model -> Form +modelForm model = Form { + formName = (mName model)++"form", + formModel = model, + fFields = map mf2ff $ filter (not.isExternalField) (mFields model) + } + +mf2ff :: ModelField -> FormField +mf2ff f@(ValidateBy fld fn) = chgValidator (mf2ff fld) fn +mf2ff f@(UsingWidget fld w) = chgWidget (mf2ff fld) w +mf2ff fld = mf2ff' (mfName fld) (mfType fld) + +chgValidator :: FormField -> FieldValidator -> FormField +chgValidator (Field n d w _) fn = Field n d w fn + +chgWidget :: (Widget w) => FormField -> w -> FormField +chgWidget (Field n d _ fn) w = Field n d w fn + +mf2ff' :: String -> ColumnType -> FormField +mf2ff' name IntegerColumn = Field name "" inputbox noValidate +mf2ff' name StringColumn = Field name "" inputbox noValidate + +addFields :: Form -> [FormField] -> Form +form `addFields` lst = form {fFields = (fFields form)++lst} diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index 90bb1b1..2f90dec 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts, ImpredicativeTypes, RankNTypes #-} +-- | HTML forms generation and validation. module Framework.Forms.Types (Form (..), FormField (..), HTMLForm (..), @@ -9,37 +10,17 @@ module Framework.Forms.Types ) where import Framework.Types -import Framework.ORM +import Framework.ORM.Types import Framework.Controller +import Framework.Forms.HTMLTypes + type FormController = AController Form -- | Form plugin transforms a Form type FormsPlugins = [Form -> FormController] --- $doc --- HTML forms generation and validation. - --- | Types of this class represent HTML widgets -class Widget w where - -- | Type of widget content; not used at the moment. - type WContent w - -- | Generate HTML for widget - html :: w -- ^ A widget - -> String -- ^ Widget's html \"name\" attribute - -> String -- ^ Value of widget - -> HTMLTag - -- | Read widget's value from string. Not used yet. - wRead :: String -> WContent w - -type HTML = [HTMLTag] - -data HTMLTag = Tag { - tagName :: String, - tagAttrs :: [FormVar], - tagContent :: HTML, - mayCollapse :: Bool -- ^ May we collapse <tag></tag> to <tag/> ? - } - | Text String +-- | Form validator takes request and returns either list of erroneus filled field or filled Model +type FormValidator = HttpRequest -> Either [String] Model data HTMLForm = HTMLForm { visibleFields :: HTML, @@ -48,11 +29,6 @@ data HTMLForm = HTMLForm { formId :: String, formAction :: String } --- | Form validator takes request and returns either list of erroneus filled field or filled Model -type FormValidator = HttpRequest -> Either [String] Model --- | Field validator takes field value and returns either error message or validated value -type FieldValidator = HttpRequest -> String -> String -> Either String String - data FormField = forall w. (Widget w) => Field { fName :: String, fLabel :: String, @@ -60,8 +36,12 @@ data FormField = forall w. (Widget w) => Field { fValidate :: FieldValidator } +instance Show FormField where + show (Field n l _ _) = l++": "++n + data Form = Form { formName :: String, formModel :: Model, fFields :: [FormField] } + deriving (Show) diff --git a/Framework/Modules/TextCaptcha/FormProcessors.hs b/Framework/Modules/TextCaptcha/FormProcessors.hs index c37e337..d0a1a26 100644 --- a/Framework/Modules/TextCaptcha/FormProcessors.hs +++ b/Framework/Modules/TextCaptcha/FormProcessors.hs @@ -56,7 +56,7 @@ randomCaptcha = do 1 -> TCSub x y 2 -> TCMul x y -isNum s = ((head s) `elem` "-0123456789") && (all isDigit (tail s)) +isNum s = (not $ null s) && ((head s) `elem` "-0123456789") && (all isDigit (tail s)) validateCaptcha :: FieldValidator validateCaptcha rq name str = diff --git a/Framework/ORM/Models.hs b/Framework/ORM/Models.hs index fc435a9..bab1a6a 100644 --- a/Framework/ORM/Models.hs +++ b/Framework/ORM/Models.hs @@ -45,10 +45,12 @@ getPK model = getPK' $ mFields model -- | Connected model for foreign key foreignModel :: ColumnType -> Model foreignModel (ForeignKey m _) = m +foreignModel _ = error "Trying to get foreign model for ordinary field" -- | Connected foreign field for foreign key foreignField :: ColumnType -> String foreignField (ForeignKey _ f) = f +foreignField _ = error "Trying to get foreign field for ordinary field" -- | Check if this field is PrimaryKey, ForeignKey or CurrentDate isExternalField :: ModelField -> Bool @@ -82,12 +84,14 @@ setCached model name tp value = model { mCached = updateField (mCached model) na record :: Model -- ^ Empty model (with unfilled fields) -> [SqlValue] -- ^ List of values -> Model -- ^ Model with filled fields -record m lst = m { mFields = filledFields } +record m lst = m { mFields = combine (mFields m) lst} where - filledFields = combine (mFields m) lst - combine _ [] = [] - combine [] _ = [] - combine flds@(f@(name:::tp):fs) vals@(x:xs) = + combine (_:_) [] = [] + combine [] lst = [] + combine ((FilledField name tp _):fs) (x:xs) = (FilledField name tp x):(combine fs xs) + combine ((ValidateBy fld _):fs) (x:xs) = combine (fld:fs) (x:xs) + combine ((UsingWidget fld _):fs) (x:xs) = combine (fld:fs) (x:xs) + combine (f@(name:::tp):fs) vals@(x:xs) = if isExternalField f then (FilledField name tp (defaultValue tp)):(combine fs vals) else (FilledField name tp x):(combine fs xs) @@ -97,26 +101,41 @@ record' :: Model -> [SqlValue] -> Model record' m lst = m { mFields = filledFields } where filledFields = combine (mFields m) lst + combine _ [] = [] combine [] lst = combine' (mCached m) lst combine ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine fs xs) + combine ((FilledField name tp _):fs) (x:xs) = (FilledField name tp x):(combine fs xs) + combine ((ValidateBy fld _):fs) (x:xs) = combine (fld:fs) (x:xs) + combine ((UsingWidget fld _):fs) (x:xs) = combine (fld:fs) (x:xs) + combine' [] _ = [] + combine' lst [] = lst combine' ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine' fs xs) + combine' ((FilledField name tp _):fs) (x:xs) = (FilledField name tp x):(combine' fs xs) + combine' ((ValidateBy fld _):fs) lst = combine' (fld:fs) lst + combine' ((UsingWidget fld _):fs) lst = combine' (fld:fs) lst -- | Get name of field fieldName :: ModelField -> String fieldName (n:::_) = n fieldName (FilledField n _ _) = n +fieldName (ValidateBy fld _) = fieldName fld +fieldName (UsingWidget fld _) = fieldName fld -- | Get type of field fieldType :: ModelField -> ColumnType fieldType (_:::tp) = tp fieldType (FilledField _ tp _) = tp +fieldType (ValidateBy fld _) = fieldType fld +fieldType (UsingWidget fld _) = fieldType fld -- | Get value of field fieldValue :: ModelField -> SqlValue fieldValue (_:::tp) = defaultValue tp fieldValue (FilledField _ _ v) = v +fieldValue (ValidateBy fld _) = fieldValue fld +fieldValue (UsingWidget fld _) = fieldValue fld fieldValue' :: (CD.Convertible SqlValue a) => ModelField -> a fieldValue' f = fromSql $ fieldValue f diff --git a/Framework/ORM/Types.hs b/Framework/ORM/Types.hs index 2708a7b..76dad7d 100644 --- a/Framework/ORM/Types.hs +++ b/Framework/ORM/Types.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE ExistentialQuantification #-} module Framework.ORM.Types where import Database.HDBC (SqlValue(..)) +import Framework.Types +import Framework.Forms.HTMLTypes + ---------------------------------------------------------------------------------- -- * SQL query ADT @@ -91,7 +95,23 @@ data ColumnType = IntegerColumn | StringColumn | BoolColumn | CurrentDateColumn - deriving (Show,Eq) + +instance Show ColumnType where + show IntegerColumn = "Integer" + show PrimaryKey = "Primary key" + show (ForeignKey m f) = "Foreign key for "++f++" in "++(mName m) + show StringColumn = "String" + show BoolColumn = "Bool" + show CurrentDateColumn = "Current timestamp" + +instance Eq ColumnType where + IntegerColumn == IntegerColumn = True + PrimaryKey == PrimaryKey = True + (ForeignKey m f) == (ForeignKey m' f') = ((mName m)==(mName m')) && (f==f') + StringColumn == StringColumn = True + BoolColumn == BoolColumn = True + CurrentDateColumn == CurrentDateColumn = True + _ == _ = False -- | DB model (table) itself data Model = Model { @@ -102,10 +122,32 @@ data Model = Model { defaultOrdering :: [SQLOrder], -- ^ How to sort list of this models by default perPage :: Maybe Int -- ^ Default paging } - deriving (Eq,Show) + deriving (Show) + +instance Eq Model where + m1 == m2 = (mName m1) == (mName m2) -- | Field for Model data ModelField = String ::: ColumnType | FilledField String ColumnType SqlValue - deriving (Eq,Show) + | ValidateBy ModelField FieldValidator + | forall w. Widget w => UsingWidget ModelField w + +instance Show ModelField where + show (name:::_) = name + show (FilledField _ _ val) = show val + show (ValidateBy f _) = show f + show (UsingWidget f _) = show f + +mfName :: ModelField -> String +mfName (name:::_) = name +mfName (FilledField name _ _) = name +mfName (ValidateBy fld _) = mfName fld +mfName (UsingWidget fld _) = mfName fld + +mfType :: ModelField -> ColumnType +mfType (_:::tp) = tp +mfType (FilledField _ tp _) = tp +mfType (ValidateBy fld _) = mfType fld +mfType (UsingWidget fld _) = mfType fld diff --git a/Framework/Types.hs b/Framework/Types.hs index ad57334..a55ebf2 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -33,6 +33,9 @@ instance Show CF.ConfigParser where type HttpRequest = Request String type HttpResponse = Response String +-- | Field validator takes field value and returns either error message or validated value +type FieldValidator = HttpRequest -> String -> String -> Either String String + -- | HTTP (GET or POST) variable can contain just a string or an uploaded file. data HttpVar = Str String | POSTfile { diff --git a/TODO b/TODO index 7fa7d90..01873a8 100644 --- a/TODO +++ b/TODO @@ -1,13 +1,15 @@ TODO + * (?) Генерация структуры Form по Model (с возможностью переопределить, или просто не использовать); + * Удобные средства расширения форм (в т.ч. и для использования в Form processors); + * Средства создания "мастеров"; + * (?) Автоматические CRUD-контроллеры; * Человеческая обработка завершения программы; - * Соответственно, все параметры, которые сейчас hard-coded, брать из конфига; + * Все параметры, которые сейчас hard-coded, брать из конфига; * [PARTIALLY DONE] Более высокоуровневый интерфейс для кэша - чтоб было легко закэшировать результат всей функции; * [PARTIALLY DONE] Соответственно, простые средства для инвалидации кэша; * [PARTIALLY DONE] Более продвинутые и высокоуровневые функции генерации SQL; * (?) Слой абстракции от диалекта SQL; - * (?) Генерация структуры Form по Model (с возможностью переопределить, или просто не использовать); - * (?) Автоматические CRUD-контроллеры; * (?) Генерация описаний моделей по БД; * (!) Документация ко всей этой красоте. * Протестировать поддержку PUT web-сервером;