formlets-0.3: Text/Formlets.hs

module Text.Formlets ( input', inputFile, fmapFst
                     , check, ensure, ensures
                     , runFormState 
                     , xml, plug
                     , Env , Form , Plus (..)
                     , File (..), ContentType (..), FormContentType (..)
                     )
                     where

import Control.Applicative
import Control.Applicative.Error
import Control.Applicative.State
import Data.Maybe (isJust)
import qualified Data.ByteString.Lazy as BS

-- Form stuff
type Env = [(String, Either String File)]
type FormState = Names
type Names = Integer
type Name = String
type Collector a = Env -> a
data FormContentType = UrlEncoded | MultiPart deriving (Eq, Show, Read)
newtype Form xml a = Form { deform :: Env -> State FormState (Collector (Failing a), xml, FormContentType) }
data File = File {content :: BS.ByteString, fileName :: String, contentType :: ContentType} deriving (Eq, Show, Read)
data ContentType = ContentType { ctType :: String
                               , ctSubtype :: String
                               , ctParameters :: [(String, String)]
                               }
                               deriving (Eq, Show, Read)

class Plus a where
  zero :: a
  plus :: a -> a -> a

-- | Apply a predicate to a value and return Success or Failure as appropriate
ensure :: Show a 
       => (a -> Bool) -- ^ The predicate
       -> String      -- ^ The error message, in case the predicate fails
       -> a           -- ^ The value
       -> Failing a
ensure p msg x | p x = Success x
               | otherwise = Failure [msg]

-- | Apply multiple predicates to a value, return Success or all the Failure messages
ensures :: Show a
        => [(a -> Bool, String)] -- ^ List of predicate functions and error messages, in case the predicate fails
        -> a                     -- ^ The value
        -> Failing a
ensures ps x | null errors = Success x
             | otherwise   = Failure errors
    where errors = [ err | (p, err) <- ps, not $ p x ]

-- | Helper function for genereting input components based forms.
input' :: (String -> String -> xml) -> Maybe String -> Form xml String
input' i defaultValue = Form $ \env -> mkInput env <$> freshName
   where mkInput env name = (fromLeft name . (lookup name),
                             i name (value name env), UrlEncoded)
         value name env = maybe (maybe "" id defaultValue) fromLeft' (lookup name env)
         fromLeft' (Left x) = x
         fromLeft' _        = ""
         fromLeft n Nothing         = Failure [n ++ " is not in the data"]
         fromLeft n (Just (Left x)) = Success x
         fromLeft n _               = Failure [n ++ " is a file."]

inputFile :: (String -> xml) -> Form xml File
inputFile i = Form $ \env -> mkInput env <$> freshName
  where  mkInput env name    = (fromRight name . (lookup name), i name, MultiPart)
         fromRight n Nothing          = Failure [n ++ " is not in the data"]
         fromRight n (Just (Right x)) = Success x
         fromRight n _                = Failure [n ++ " is not a file"]


-- | Runs the form state
runFormState :: Env             -- ^ A previously filled environment (may be empty)
             -> Form xml a      -- ^ The form
             -> (Collector (Failing a), xml, FormContentType)
runFormState e (Form f) = evalState (f e) 0

-- | Add additional validation to an already validated component
check :: Form xml a -> (a -> Failing b) -> Form xml b
check (Form frm) f = Form $ \e -> checker (frm e)
 where checker = fmap $ fmapFst3 (f' .)
       f' (Failure x) = Failure x
       f' (Success x) = f x


instance Functor (Form xml) where
  fmap f (Form a) = Form $ \env -> (fmap . fmapFst3 . fmap . fmap) f (a env)

fmapFst  f (a, b)    = (f a, b)
fmapFst3 f (a, b, c) = (f a, b, c)

instance Plus xml => Applicative (Form xml) where
   pure = pureF
   (<*>) = applyF

pureF :: Plus xml => a -> Form xml a
pureF v = Form $ \env -> pure (const (Success v), zero, UrlEncoded)

applyF :: Plus xml => Form xml (a -> b) -> Form xml a -> Form xml b
(Form f) `applyF` (Form v) = Form $ \env -> pure combine <*> f env <*> v env
  where combine (v1, xml1, t1) (v2, xml2, t2) = (\e -> v1 e <*> v2 e, xml1 `plus` xml2, t1 `orT` t2)

orT UrlEncoded x = x
orT x UrlEncoded = x
orT x y          = x


-- | Component: just some xml
xml :: xml -> Form xml ()
xml x = Form $ \env -> pure (const $ Success (), x, UrlEncoded)

-- | Transform the XML component
plug :: Plus xml => (xml -> xml) -> Form xml a -> Form xml a
f `plug` (Form m) = Form $ \env -> pure plugin <*> m env
   where plugin (c, x, t) = (c, f x, t)

-----------------------------------------------
-- Private methods
-----------------------------------------------

freshName :: State FormState String
freshName = do n <- currentName
               modify (+1)
               return n

currentName :: State FormState String
currentName = gets $ (++) "input" . show