0 | module Web.MVC.Controller.File
 1 |
 2 | import Data.List1
 3 | import Data.String
 4 | import Text.HTML.Extra
 5 | import Web.MVC
 6 | import Web.MVC.Controller
 7 | import Web.MVC.Controller.Validation
 8 |
 9 | %default total
10 |
11 | fakeBody : String -> String
12 | fakeBody s =
13 |   case [<] <>< forget (split ('\\' ==) s) of
14 |     _ :< p => p
15 |     _      => ""
16 |
17 | fileUpdate : FileEv -> (String, Maybe File) -> (String, Maybe File)
18 | fileUpdate (NameChanged s)   (_,f) = (s,f)
19 | fileUpdate (FileChanged f s) _     = (fakeBody s, Just f)
20 |
21 | parameters {0 i     : Type}
22 |            {auto cst : Cast i DomID}
23 |            {auto ve  : ValEnv i}
24 |            {auto fe  : FileEnv i}
25 |
26 |   mandatoryBody : String -> Either String Body
27 |   mandatoryBody = checkVal {i} fe.readBody
28 |
29 |   fileDisplay : i -> FileEv -> (String, Maybe File) -> Cmd FileEv
30 |   fileDisplay u (NameChanged s)   _     =
31 |     validate (inpRef $ ve.inputID u) (mandatoryBody s)
32 |   fileDisplay u (FileChanged _ _) (s,_) =
33 |      value (inpRef $ ve.inputID u) s <+>
34 |      validate (inpRef $ ve.inputID u) (mandatoryBody s)
35 |
36 |   export %inline
37 |   fileC : i -> Controller FileEv (String, Maybe File)
38 |   fileC = updateDisp fileUpdate . fileDisplay
39 |
40 |   fileWidget : i -> (String,Maybe File) -> Node FileEv
41 |   fileWidget u ("",_) = file u Nothing
42 |   fileWidget u (s,_)  =
43 |     case mandatoryBody s of
44 |       Right b => file u (Just b)
45 |       Left _  => file u Nothing
46 |
47 |   ||| Specialized version of `input` for entering file names.
48 |   export
49 |   file : Editor i (String,Maybe File) FileEv Body
50 |   file = E fileC fileWidget noInit (mandatoryBody . fst) ini
51 |     where
52 |       ini : Maybe Body -> (String,Maybe File)
53 |       ini = (,Nothing) . maybe "" interpolate
54 |