Commit 98b9f662 authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into 308-make-use-of-active-tab-information

parents 4e95b8de 13ed3303
Pipeline #35776 passed with stage
in 6 minutes and 55 seconds
......@@ -13,12 +13,12 @@ manageStore
selectStore :: Task (String,String) //Namespace and store name
selectStore
= (enterChoiceWithShared (Title "Namespace") [] storeNamespaces
= (enterChoiceWithShared [] storeNamespaces <<@ Title "Namespace"
>&> \sNamespace -> whileUnchanged sNamespace
\mbNamespace -> case mbNamespace of
Nothing = enterChoice (Title "Stores") [ChooseFromGrid id] []
Just ns = enterChoiceWithShared (Title "Stores") [ChooseFromGrid id] (sdsFocus ns storeNames) @ (\s -> (ns,s))
) <<@ (ArrangeWithSideBar 0 TopSide 55 False)
Nothing = enterChoice [ChooseFromGrid id] [] <<@ Title "Store"
Just ns = enterChoiceWithShared [ChooseFromGrid id] (sdsFocus ns storeNames) <<@ Title "Stores" @ (\s -> (ns,s))
) <<@ ArrangeWithSideBar 0 TopSide False
//Low-level access
deleteStore :: (String,String) -> Task ()
......
......@@ -38,6 +38,35 @@ importCSVDocumentWith :: !Char !Char !Char !Document -> Task [[String]]
* @return The exported content as a document
*/
createCSVFile :: !String ![[String]] -> Task Document
/**
* Export a list of rows of fields to a comma separated vector (CSV) document.
*
* @param Separator: The field separator
* @param Quote character: The string quote character
* @param Escape character: The escape character
* @param File name: A name of the created CSV file
* @param Cells: The content to export as a list of rows of lists of fields
*
* @return The exported content as a document
*/
createCSVFileWith :: !Char !Char !Char !String ![[String]] -> Task Document
/**
* Export a list of rows of fields to a comma separated vector (CSV) document encoded in UTF-8.
* The file starts with a UTF-8 byte order mask.
* This is to make sure the Excel correctly detect the encoding when importing the file.
*
* @param Separator: The field separator
* @param Quote character: The string quote character
* @param Escape character: The escape character
* @param File name: A name of the created CSV file
* @param Cells: The content to export as a list of rows of lists of fields
*
* @return The exported content as a document
*/
createUtf8CSVFileWith :: !Char !Char !Char !String ![[String]] -> Task Document
/**
* Export a list of rows of fields to a comma separated vector (CSV) file on the server's filesystem.
*
......
......@@ -2,7 +2,7 @@ implementation module iTasks.Extensions.CSVFile
import StdBool, StdList, System.FilePath, Text, Text.CSV, System.File, Data.Error
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState
import iTasks.Extensions.Document
import iTasks, iTasks.Extensions.TextFile, iTasks.Extensions.Document
importCSVFile :: !FilePath -> Task [[String]]
importCSVFile filename = mkInstantTask eval
......@@ -28,17 +28,35 @@ where
# (filename,iworld) = documentLocation documentId iworld
= fileTaskRead taskId filename (readCSVFileWith delimitChar quoteChar escapeChar) iworld
createCSVFile :: !String ![[String]] -> Task Document
createCSVFile filename content = mkInstantTask eval
createCSVFile filename content =
withTemporaryDirectory
(\dir -> let tmpFilePath = dir </> filename in exportCSVFile filename content >-| importDocument tmpFilePath)
createCSVFileWith :: !Char !Char !Char !String ![[String]] -> Task Document
createCSVFileWith delimitChar quoteChar escapeChar filename content =
withTemporaryDirectory
( \dir ->
let tmpFilePath = dir </> filename in
exportCSVFileWith delimitChar quoteChar escapeChar filename content >-| importDocument tmpFilePath
)
createUtf8CSVFileWith :: !Char !Char !Char !String ![[String]] -> Task Document
createUtf8CSVFileWith delimitChar quoteChar escapeChar filename content =
withTemporaryDirectory
( \dir ->
let tmpFilePath = dir </> filename in
exportCSVFileWith delimitChar quoteChar escapeChar filename content >-|
importTextFile tmpFilePath >>- \fileContent ->
mkInstantTask (createDoc fileContent)
)
where
eval taskId iworld=:{current={taskTime}}
# csv = join "\n" (map (join ",") content)
# (mbDoc,iworld) = createDocument filename "text/csv" csv iworld
createDoc fileContent _ iworld
# (mbDoc, iworld) = createDocument filename "text/csv" ("\xEF\xBB\xBF" +++ fileContent) iworld
= case mbDoc of
Ok doc = (Ok doc, iworld)
Error e = (Error (dynamic e,toString e),iworld)
Ok doc -> (Ok doc, iworld)
Error e -> (Error (dynamic e, toString e), iworld)
exportCSVFile :: !FilePath ![[String]] -> Task [[String]]
exportCSVFile filename content = mkInstantTask eval
where
......
definition module iTasks.Extensions.DateTime.Gast
from iTasks.Extensions.DateTime import :: Time
from iTasks.Extensions.DateTime import :: Date, :: Time, :: DateTime
from Gast import generic genShow, generic ggen, :: GenState
derive ggen Time
derive genShow Time
derive ggen Date, Time, DateTime
derive genShow Date, Time, DateTime
implementation module iTasks.Extensions.DateTime.Gast
import StdEnv, Gast, iTasks.Extensions.DateTime
import StdEnv, Gast, Data.List, Data.Functor, iTasks.Extensions.DateTime
ggen{|Time|} _ = [{Time| hour = h, min = m, sec = s} \\ (h,m,s) <- diag3 [0,23:[1..22]] [0,59:[1..58]] [0,59,60:[1..58]]]
derive genShow Time
// Years can be negative (BC), the range of +/- 3000 years is chosen more or less arbitrarily,
// but should include most years used in realistic programs.
ggen{|Date|} _ =
[ {Date| year = y, mon = m, day = d}
\\ (y, m, d) <- diag3 [0, -3000, 3000: [-2999..2999]] [1, 12: [2..11]] [1, 31: [2..30]]
| isValid y m d
]
where
isValid :: !Int !Int !Int -> Bool
isValid y 2 d = if (isLeapYear y) (d <= 29) (d <= 28)
isValid _ 4 31 = False
isValid _ 6 31 = False
isValid _ 9 31 = False
isValid _ 11 31 = False
isValid _ _ _ = True
isLeapYear :: !Int -> Bool
isLeapYear year = (year rem 4 == 0 && year rem 100 <> 0) || year rem 400 == 0
ggen{|Time|} _ =
[{Time| hour = h, min = m, sec = s} \\ (h, m, s) <- diag3 [0, 23: [1..22]] [0, 59: [1..58]] [0, 59, 60: [1..58]]]
ggen{|DateTime|} st = (uncurry toDateTime) <$> ggen{|*|} st
derive genShow Date, Time, DateTime
definition module iTasks.Extensions.Development.CleanCode
/**
* This module provides tasks and types for dealing with Clean source code
*/
import iTasks
implementation module iTasks.Extensions.Development.CleanCode
import iTasks
viewCleanModule :: FilePath String -> Task ()
viewCleanModule baseDir moduleName
= viewInformation "TODO" [] (baseDir,moduleName) @! ()
import System.Directory, System.File
/**
* Given a list of absolute path names, offers a tree structure choice to select a file
* @param absolute paths of directories to search through
* @param only show files with given extensions, all files are shown if this list is empty
* @return selected file and the absolute path directory name it is found
*/
chooseFile :: [FilePath] [FileExtension] -> Task (FilePath,FilePath)
chooseFile paths extensions
= accWorld (getFilesInDir paths extensions)
>>- \tree -> enterChoice [Att (Title "Select File"), Att IconEdit] [ChooseWith (ChooseFromTree (\list _ -> toChoiceTree list))] (treeToList tree [])
@? adjust
where
toChoiceTree :: [(Int,(FilePath,[FilePath],FilePath))] -> [ChoiceTree FilePath]
toChoiceTree [] = []
toChoiceTree [(i,(path,[],fileName)):next]
= [{label = fileName, icon = Nothing, value = ChoiceNode i, type = LeafNode}:toChoiceTree next]
toChoiceTree [(i,(path,[dir:dirs],fileName)):next]
= [{label = dir, icon = Nothing, value = GroupNode dir, type = CollapsedNode (toChoiceTree inDir`)}:toChoiceTree outDir]
where
(inDir,outDir) = span (\(_,(_,dirs,_)) -> if (not (isEmpty dirs)) (hd dirs == dir) False) next
inDir` = [(i,(path,dirs,fileName)):[(j,(path,tl dirs,name)) \\ (j,(path,dirs,name)) <- inDir]]
adjust (Value (path,dirs,fileName) stab)
| fileName == "" = NoValue
= Value (foldl (</>) path dirs,fileName) stab
adjust NoValue = NoValue
treeToList :: [(FilePath,[TreeNode FilePath])] [FilePath] -> [(FilePath,[FilePath],FilePath)]
treeToList [] dirs = []
treeToList [(path,[Leaf file:files]):tree] dirs = [(path,dirs,file): treeToList [(path,files)] dirs] ++ treeToList tree []
treeToList [(path,[Node dir childs :files]):tree] dirs = treeToList [(path,childs)] (dirs++[dir]) ++ treeToList [(path,files)] dirs ++ treeToList tree []
treeToList [_:tree] dirs = treeToList tree []
getFilesInDir :: [FilePath] [FileExtension] !*World -> ([(FilePath,[TreeNode FilePath])],*World)
getFilesInDir [] extensions w = ([],w)
getFilesInDir [path:paths] extensions w
# (treeFiles,w) = getTree (takeDirectory path) [dropDirectory path] w
# (ntrees,w) = getFilesInDir paths extensions w
= ([(takeDirectory path,treeFiles):ntrees],w)
where
getTree absolutePath [] w = ([],w)
getTree absolutePath [fileName:fileNames] w
# absoluteFileName = absolutePath </> fileName
# (mbInfo,w) = getFileInfo absoluteFileName w
| isError mbInfo = getTree absolutePath fileNames w
| (fromOk mbInfo).directory // file is directory name
# (filesInDir,w) = getFilesInPath absoluteFileName w
# (dirNodes,w) = getTree absoluteFileName filesInDir w
# (filesNodes,w) = getTree absolutePath fileNames w
= case dirNodes of
[] -> (filesNodes,w)
_ -> ([Node fileName dirNodes:filesNodes],w)
| isEmpty extensions || isMember (snd (splitExtension fileName)) extensions
# (treeNodes,w) = getTree absolutePath fileNames w
= ([Leaf fileName:treeNodes],w)
= getTree absolutePath fileNames w
getFilesInPath :: !FilePath !*World -> ([FilePath],!*World)
getFilesInPath path w
# (mbFiles,w) = readDirectory path w
| isError mbFiles = ([],w)
= ([name \\ name <- fromOk mbFiles | name <> "." && name <> ".."],w)
readDir :: !FilePath !*World -> ([FilePath],!*World)
readDir path w
# (mbInfo,w) = getFileInfo path w
| isError mbInfo = ([],w)
| (fromOk mbInfo).directory = getFilesInPath path w
......@@ -14,8 +14,9 @@ import iTasks
* @param Recipients: The recipient addresses
* @param Subject: The subject line of the e-mail message
* @param Body: The body of the e-mail message
* @param Attachments: Attachments added to the e-mail message
*/
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
sendEmail :: ![EmailOpt] !String ![String] !String !String ![Attachment] -> Task ()
/**
* Send an e-mail message with HTML body.
......@@ -25,8 +26,9 @@ sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
* @param Recipients: The recipient addresses
* @param Subject: The subject line of the e-mail message
* @param Body: The HTML body of the e-mail message. Text has to be UTF-8 encoded.
* @param Attachments: Attachments added to the e-mail message.
*/
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag ![Attachment] -> Task ()
//Options for sendEmail
:: EmailOpt
......@@ -34,3 +36,9 @@ sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
| EmailOptSMTPServerPort !Int //TCP port of the SMTP server to use. Default: 25
| EmailOptExtraHeaders ![(String,String)] //Additional headers to add before the body
| EmailOptTimeout !Timeout // TCP timeout
//* Email attachment.
:: Attachment =
{ name :: !String //* The attachment's filename.
, content :: !{#Char} //* Content of the attachment, arbitrary binary data.
}
implementation module iTasks.Extensions.Email
import iTasks
import StdEnv
import Data.Functor, Data.Func
import Text, Text.HTML
import Text, Text.HTML, Text.Encodings.Base64
import iTasks
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
sendEmail opts sender recipients subject body
sendEmail :: ![EmailOpt] !String ![String] !String !String ![Attachment] -> Task ()
sendEmail opts sender recipients subject body attachments
= tcpconnect server port timeout (constShare ()) {ConnectionHandlers|onConnect=onConnect,onData=onData,onDisconnect=onDisconnect,onShareChange = \l _ = (Ok l, Nothing, [], False), onDestroy= \s->(Ok s, [])}
@! ()
where
......@@ -25,7 +26,7 @@ where
((\recipient -> (smtpTo recipient, 250)) <$> recipients)
++
[(smtpData, 354)
,(smtpBody sender recipients headers subject body, 250)
,(smtpBody sender recipients headers subject body attachments, 250)
,(smtpQuit, 221)
]
......@@ -50,10 +51,15 @@ where
onDisconnect _ _
= (Error "SMTP server disconnected unexpectedly",Nothing)
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
sendHtmlEmail opts sender recipients subject body =
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag ![Attachment] -> Task ()
sendHtmlEmail opts sender recipients subject body attachments =
sendEmail
[EmailOptExtraHeaders [("content-type", "text/html; charset=UTF8")]: opts] sender recipients subject htmlString
[EmailOptExtraHeaders [("content-type", "text/html; charset=UTF8")]: opts]
sender
recipients
subject
htmlString
attachments
where
// avoid too long lines (SMTP allows a max length of 1000 characters only)
// by inserting a newline (\r\n is required for mails) after each tag
......@@ -64,15 +70,36 @@ smtpHelo = "HELO localhost\r\n"
smtpFrom email_from = "MAIL FROM:<" +++ (cleanupEmailString email_from) +++ ">\r\n"
smtpTo email_to = "RCPT TO:<" +++ (cleanupEmailString email_to) +++ ">\r\n"
smtpData = "DATA\r\n"
smtpBody email_from email_to email_headers email_subject email_body
= concat [k+++":"+++ v +++ "\r\n" \\ (k,v) <-
[("From",cleanupEmailString email_from)
: (\email_to -> ("To",cleanupEmailString email_to)) <$> email_to
] ++
[("Subject",cleanupEmailString email_subject)
:email_headers]
]
+++ "\r\n" +++ email_body +++ "\r\n.\r\n"
smtpBody email_from email_to bodyHeaders email_subject email_body attachments =
concat $ flatten $
[ [k, ":", v, "\r\n"]
\\ (k, v) <-
[ ("From", cleanupEmailString email_from)
: (\email_to -> ("To", cleanupEmailString email_to)) <$> email_to
]
++
[("Subject", cleanupEmailString email_subject)]
]
++
if (isEmpty attachments) [] [["Content-Type: multipart/mixed; boundary=sep\r\n--sep\r\n"]]
++
[[k, ":", v, "\r\n"] \\ (k, v) <- bodyHeaders]
++
[["\r\n", email_body, "\r\n"], if (isEmpty attachments) [] ["--sep"], ["\r\n"]]
++
[ flatten $
[ [ "content-type: application/octet-stream; name=\"", attachment.Attachment.name, "\"\r\n"
, "content-disposition: attachment; filename=\"", attachment.Attachment.name, "\"\r\n"
, "content-transfer-encoding: base64\r\n"
, "\r\n"
]
, withRestrictedLineLength (base64Encode attachment.content)
, ["\r\n--sep\r\n"]
]
\\ attachment <- attachments
]
++
[[".\r\n"]]
smtpQuit = "QUIT\r\n"
//Utility functions
......@@ -100,3 +127,13 @@ getHeadersOpt [x:xs] = getHeadersOpt xs
getTimeoutOpt [] = Nothing
getTimeoutOpt [EmailOptTimeout t:xs] = Just t
getTimeoutOpt [x:xs] = getTimeoutOpt xs
//* Cut into lines of 1000 character (including "\r\n"), to fulfil SMTP standard.
withRestrictedLineLength :: !String -> [String]
withRestrictedLineLength str = reverse $ withRestrictedLineLength` 0 []
where
withRestrictedLineLength` i acc
| strSize - i <= 998 = [str % (i, strSize - 1): acc]
| otherwise = withRestrictedLineLength` (i + 998) ["\r\n", str % (i, i + 997): acc]
strSize = size str
......@@ -7,12 +7,24 @@ import iTasks
from Data.Map import :: Map
from System.FilePath import :: FilePath
//Determine if a path is part of the colleciton based on the relative path and whether it is a directory
:: FileFilter :== FilePath Bool -> Bool
/**
* Determine if a path is part of the collection based on the relative path
* The path is tested against est the path against a list of 'glob'-like rules.
* Return the decision for the first rule that matches.
* If none of the rules match, the default decision is to exclude the path
*/
:: FileFilter :== [(FileFilterRule,FileFilterDecision)]
:: FileFilterRule :== String
:: FileFilterDecision
= IncludeFile //The file is part of the managed collection
| ExcludeFile //The file is not part of the collection, do not touch it
| ReferenceFile //The file is part of the collection, but don't read or write its content
:: FileCollection :== Map String FileCollectionItem
:: FileCollectionItem
= FileContent String
| FileReference
| FileCollection FileCollection
derive class iTask FileCollectionItem
......@@ -22,10 +34,14 @@ derive class iTask FileCollectionItem
* It will ignore all files in the directory that don't match the filter
* @param The filter that specifies which files and directories are part of the collection
# @param Readonly flag: When this is true, the files are only read, never written
* @param Delete flag: When this is true, files on disk that are not in the collection, but match the filter are deleted during a write.
If it is false, entries on that are removed are only marked in a file called 'exclude.txt' but not deleted.
*/
fileCollection :: FileFilter Bool -> SDSSource FilePath FileCollection FileCollection
fileCollection :: FileFilter Bool Bool -> SDSSource FilePath FileCollection FileCollection
//Filter to ignore all hidden files (e.g. starting with a '.')
ignoreHiddenFiles :: FileFilter
//Access utilities:
getStringContent:: String FileCollection -> Maybe String
......@@ -35,6 +51,3 @@ getIntContent :: String FileCollection -> Maybe Int
setIntContent :: String Int FileCollection -> FileCollection
toPaths :: FileCollection -> [FilePath]
//Filter to ignore all hidden files (e.g. starting with a '.')
ignoreHiddenFiles :: FileFilter
......@@ -6,4 +6,4 @@ definition module iTasks.Extensions.FileDialog
*/
import iTasks
editFilePath :: String Action (Maybe FilePath) -> Task (Maybe FilePath)
editFilePath :: String Action !(Maybe FilePath) -> Task (Maybe FilePath)
......@@ -10,7 +10,7 @@ from Data.Map import unions
derive class iTask FileInfo, Tm
editFilePath :: String Action (Maybe FilePath) -> Task (Maybe FilePath)
editFilePath :: String Action !(Maybe FilePath) -> Task (Maybe FilePath)
editFilePath title action initialPath
= (determineInitialDir initialPath
>>- \(initDir,initFile) ->
......@@ -35,33 +35,33 @@ where
accWorldError (getFileInfo fullPath) snd
@ \{FileInfo|directory} -> if directory (fullPath,Nothing) (takeDirectory fullPath,Just (dropDirectory fullPath))
navigateUp :: (Shared (FilePath,Maybe String)) -> Task (FilePath, Maybe String)
navigateUp :: (Shared sds (FilePath,Maybe String)) -> Task (FilePath, Maybe String) | RWShared sds
navigateUp sSelection
= editSharedChoiceWithShared () [ChooseFromDropdown fst] (ancestorDirectories sSelection) (selection sSelection)
= editSharedChoiceWithShared [ChooseFromDropdown fst] (ancestorDirectories sSelection) (selection sSelection)
chooseFromCurrentDirectory :: (Shared (FilePath,Maybe String))-> Task (FilePath, Maybe String)
chooseFromCurrentDirectory :: (Shared sds (FilePath,Maybe String))-> Task (FilePath, Maybe String) | RWShared sds
chooseFromCurrentDirectory sSelection
= editSharedChoiceWithShared () [ChooseFromList view] (filesInCurDir sSelection) (selection sSelection)
= editSharedChoiceWithShared [ChooseFromList view] (filesInCurDir sSelection) (selection sSelection)
where
view (path,Nothing) = "[DIR] " +++ dropDirectory path
view (path,Just filename) = "[FILE] " +++ filename
selection sds = mapReadWrite (Just, const) sds
selection sds = mapReadWrite (Just, const) Nothing sds
editFilename :: (Shared (FilePath, Maybe String)) -> Task (FilePath,Maybe String)
editFilename sSelection = updateSharedInformation () [UpdateAs snd (\(d,_) f -> (d,f))] sSelection
editFilename :: (Shared sds (FilePath, Maybe String)) -> Task (FilePath,Maybe String) | RWShared sds
editFilename sSelection = updateSharedInformation [UpdateSharedAs snd (\(d,_) f -> (d,f)) \_->id] sSelection
fileListLayout = setUIAttributes (unions [sizeAttr FlexSize (ExactSize 200),minWidthAttr (ExactBound 400)])
fileListLayout = setUIAttributes (unions [sizeAttr FlexSize (ExactSize 200)/*, minWidthAttr (ExactBound 400)*/])
navigateUpLayout = layoutSubUIs SelectChildren (setUIAttributes (widthAttr FlexSize))
ancestorDirectories :: (SDS () (FilePath,Maybe String) (FilePath,Maybe String))
-> SDS () [(FilePath,Maybe String)] (FilePath,Maybe String)
ancestorDirectories :: (Shared sds (FilePath,Maybe String))
-> SDSLens () [(FilePath,Maybe String)] (FilePath,Maybe String) | RWShared sds
ancestorDirectories sds = mapRead (ancestors o fst) sds
where
ancestors "" = [("/",Nothing)]
ancestors path = [(path,Nothing):ancestors (takeDirectory path)]
filesInCurDir :: (SDS () (FilePath,Maybe String) (FilePath,Maybe String)) -> SDS () [(FilePath,Maybe String)] ()
filesInCurDir :: (Shared sds (FilePath,Maybe String)) -> SDSSequence () [(FilePath,Maybe String)] () | RWShared sds
filesInCurDir selection
= sdsSequence "filesIn" id (\() (p,_) -> p) (\() _ = Right snd)
(SDSWriteConst (\_ _ -> Ok Nothing)) (SDSWriteConst (\_ _ -> Ok Nothing)) selection directoryListingWithDir
......@@ -69,7 +69,7 @@ filesInCurDir selection
//Files are listed as (<current dir>,Just <file name>)
//Directories are listed as (<child dir>, Nothing)
directoryListingWithDir :: SDS FilePath [(FilePath,Maybe String)] ()
directoryListingWithDir :: SDSLens FilePath [(FilePath,Maybe String)] ()
directoryListingWithDir = mapRead (map combine) directoryListingWithInfo
where
combine (parentDir,filename,{FileInfo|directory})
......@@ -78,7 +78,7 @@ where
//UTIL
//Entries are: (Dir, Filename, Fileinfo)
directoryListingWithInfo :: SDS FilePath [(FilePath,String,FileInfo)] ()
directoryListingWithInfo :: SDSSource FilePath [(FilePath,String,FileInfo)] ()
directoryListingWithInfo = createReadOnlySDSError read
where
read path iworld = case readDirectory path iworld of
......
definition module iTasks.Extensions.Picture.Interaction
import iTasks
import iTasks.Extensions.Picture.JPEG
showJPEGPicture :: JPEGPicture -> Task (Maybe JPEGPicture)
implementation module iTasks.Extensions.Picture.Interaction
import iTasks
import iTasks.API.Core.Client.Tasklet
import iTasks.Extensions.Picture.JPEG
showJPEGPicture :: JPEGPicture -> Task (Maybe JPEGPicture)
showJPEGPicture photo
= mkTask (showJPEGPictureTasklet photo)
showJPEGPictureTasklet :: JPEGPicture -> Tasklet (Maybe JPEGPicture) (Maybe JPEGPicture)
showJPEGPictureTasklet picture
=
{ genUI = showJPEGPictureGUI picture
, resultFunc = \_ -> Value (Just picture) True
, tweakUI = setTitle "Picture"
}
where
showJPEGPictureGUI picture _ _ iworld
# gui = { width = WrapSize
, height = WrapSize
, html = RawText htmlText
, eventHandlers = []
}
= (TaskletHTML gui, Nothing, iworld)
htmlText :: String
htmlText = "<img style='max-width: 300px;' src='data:image/jpg;base64," +++ picture +++ "' alt='no photo' />"
......@@ -21,5 +21,7 @@ derive JSONEncode JPEGPicture
derive JSONDecode JPEGPicture
derive gEq JPEGPicture
gEditor{|JPEGPicture|} = comapEditorValue (\(JPEGPicture val) -> ImgTag [SrcAttr val, AltAttr "no photo", StyleAttr ("max-width: 200px; max-height: 200px;")])
htmlView
gEditor{|JPEGPicture|}
= comapEditorValue (\(JPEGPicture val) -> ImgTag
[SrcAttr ("data:image/jpg;base64,"+++val), AltAttr "no photo", StyleAttr ("max-width: 200px; max-height: 200px;")])
htmlView
implementation module iTasks.Extensions.TextFile
import StdBool, StdList, StdFile, StdArray, System.FilePath, Text, System.File, Data.Error, StdString
import StdBool, StdList, StdFile, StdArray, StdString, System.FilePath, Text, System.File, Data.Error, Data.Func
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState
import iTasks.Extensions.Document
......@@ -38,14 +38,15 @@ fileTaskRead taskId filename f iworld=:{IWorld|current={taskTime},world}
# (ok,world) = fclose file world
| not ok = (closeException filename,{IWorld|iworld & world = world})
= (Ok res, {IWorld|iworld & world = world})
readAll file
# (chunk,file) = freads file CHUNK_SIZE
| size chunk < CHUNK_SIZE
= (chunk,file)
| otherwise
# (rest,file) = readAll file
= (chunk +++ rest,file)
readAll :: !*File -> (!String, !*File)
readAll file = readAll` [] file
where
readAll` :: ![String] !*File -> (!String, !*File)
readAll` acc file
# (chunk,file) = freads file CHUNK_SIZE
| size chunk < CHUNK_SIZE = (concat $ reverse [chunk: acc], file)
| otherwise = readAll` [chunk: acc] file
writeAll content file
= fwrites content file
......
......@@ -54,13 +54,13 @@ where
removeIfOutdated options {TaskMeta|taskId=TaskId instanceNo _,connectedTo,lastIO,build,createdAt} iworld=:{options={appVersion},clock=tNow}
| if (lastIO =:(Just _))
(tNow - fromJust lastIO > options.EngineOptions.sessionTime)
((build <> appVersion) || ((tNow - createdAt) > options.EngineOptions.sessionTime))