Commit 38fadd49 authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into remove-or-fix-erroneous-files

parents 06cae2fa d85d3254
Pipeline #35762 passed with stage
in 6 minutes and 45 seconds
implementation module C2.Framework.MapEnvironment
import StdArray
import iTasks
import iTasks.UI.Definition
import iTasks.Extensions.DateTime
import qualified Data.Map as DM
from Data.Map import :: Map, instance Functor (Map k)
......@@ -14,12 +12,13 @@ import qualified Data.Heap as DH
from Data.Heap import :: Heap
import Data.GenLexOrd
from C2.Framework.Logging import addLog
import C2.Apps.ShipAdventure.Types
import C2.Apps.ShipAdventure.Types => qualified >>=, >>|, sequence
import Data.List
import Data.Eq
import Data.Maybe
import Data.Functor
import Data.Either
import Control.Monad => qualified forever, return
import StdMisc
......@@ -323,11 +322,11 @@ addActorToMap :: !(DrawMapForActor r o a) !(Actor o a) !Coord3D
-> Task () | iTask r & iTask o & iTask a
addActorToMap roomViz actor location inventoryForSectionShare shipStatusShare userToActorShare inventoryForAllSectionsShare
= get maps2DShare
>>= \ms2d -> if (existsSection location ms2d)
>>- \ms2d -> if (existsSection location ms2d)
( upd ('DM'.put actor.userName actor) userToActorShare
>>| move (0, {col = 0, row = 0}) location actor.userName
>>| moveAround roomViz actor.userName inventoryForSectionShare shipStatusShare userToActorShare inventoryForAllSectionsShare)
(Hint ("Section with number: " <+++ location <+++ " does not exist") @>> viewInformation [] () >>| return ())
>-| move (0, {col = 0, row = 0}) location actor.userName
>-| moveAround roomViz actor.userName inventoryForSectionShare shipStatusShare userToActorShare inventoryForAllSectionsShare)
(Hint ("Section with number: " <+++ location <+++ " does not exist") @>> viewInformation [] () >>- \_->return ())
:: UITag :== [Int]
......@@ -531,7 +530,7 @@ pickupObject :: !Coord3D !(Object o) !User !(UserActorShare o a) !(FocusedSectio
-> Task () | iTask o & iTask a
pickupObject c3d object user userActorShare shFocusedSectionInventory
= upd f userActorShare
>>| upd (\inv -> 'DIS'.fromList [(obj.objId, obj) \\ obj <- 'DIS'.elems inv | obj.objId /= object.objId]) (sdsFocus c3d shFocusedSectionInventory) @! ()
>-| upd (\inv -> 'DIS'.fromList [(obj.objId, obj) \\ obj <- 'DIS'.elems inv | obj.objId /= object.objId]) (sdsFocus c3d shFocusedSectionInventory) @! ()
where
f userActorMap = case 'DM'.get user userActorMap of
Just actor
......@@ -542,7 +541,7 @@ dropObject :: !Coord3D !(Object o) !User !(UserActorShare o a) !(FocusedSectionI
-> Task () | iTask o & iTask a
dropObject c3d object user userActorShare shFocusedSectionInventory
= upd f userActorShare
>>| upd (\inv -> 'DIS'.put object.objId object inv) (sdsFocus c3d shFocusedSectionInventory) @! ()
>-| upd (\inv -> 'DIS'.put object.objId object inv) (sdsFocus c3d shFocusedSectionInventory) @! ()
where
f userActorMap = case 'DM'.get user userActorMap of
Just actor
......@@ -601,9 +600,9 @@ autoMove thisSection target pathFun user shipStatusShare userToActorShare
>>- \graph -> case pathFun thisSection target statusMap exitLocks hopLocks graph of
Just (path=:[nextSection:_], _)
= waitForTimer 1
>>| move roomCoord nextSection user
>>| addLog user "" ("Has moved to Section " <+++ nextSection)
>>| autoMove nextSection target pathFun user shipStatusShare userToActorShare
>-| move roomCoord nextSection user
>-| addLog user "" ("Has moved to Section " <+++ nextSection)
>-| autoMove nextSection target pathFun user shipStatusShare userToActorShare
_ = return False
_ = return False
......@@ -614,7 +613,7 @@ autoMove thisSection target pathFun user shipStatusShare userToActorShare
updActorStatus :: !User !(a -> a) !(UserActorShare o a) -> Task () | iTask a & iTask o
updActorStatus user upd userToActorShare
= get userToActorShare
>>= \userActorMap -> case 'DM'.get user userActorMap of
>>- \userActorMap -> case 'DM'.get user userActorMap of
Just actor -> set ('DM'.put user {actor & actorStatus = upd actor.actorStatus} userActorMap) userToActorShare @! ()
Nothing -> return ()
......@@ -641,7 +640,7 @@ findUser :: !User !SectionUsersMap !(UserActorMap o a) -> Maybe (!Coord3D, !Acto
findUser usr sectionUsersMap userActorMap
= 'DM'.get usr userActorMap
>>= \a -> sectionForUser usr sectionUsersMap
>>= \s -> return (s, a)
>>= \s -> pure (s, a)
// room status updating
toggleDoor :: !Coord3D !Dir -> Task ()
......@@ -652,7 +651,7 @@ toggleDoor roomNo=:(floorIdx, c2d) exit
= get focus1
>>- \locks1 -> get focus2
>>- \locks2 -> set (newLocks exit locks1) focus1
>>| set (newLocks (opposite exit) locks2) focus2 @! ()
>-| set (newLocks (opposite exit) locks2) focus2 @! ()
where
newLocks :: !Dir ![Dir] -> [Dir]
newLocks dir locks
......@@ -667,7 +666,7 @@ toggleHop fromRoom toRoom
= get focus1
>>- \locks1 -> get focus2
>>- \locks2 -> set (newLocks fromRoom locks1) focus1
>>| set (newLocks toRoom locks2) focus2 @! ()
>-| set (newLocks toRoom locks2) focus2 @! ()
where
newLocks :: !Coord3D ![Coord3D] -> [Coord3D]
newLocks c3d locks
......
module examples
import iTasks.Extensions.Distributed.iTasks
import iTasks.WF.Combinators.Common
import Data.Functor
import Data.Maybe
......
......@@ -4,12 +4,13 @@ import iTasks
import Ligretto.UoD
import Ligretto.UI
import Data.Maybe
from Control.Monad import class Monad(bind), `b`
// Task description of Ligretto:
play_Ligretto :: Task (!Color,!String)
play_Ligretto
= get currentUser
>>= \me -> invite_friends
>>- \me -> invite_friends
>>= \them -> let us = zip2 (colors (1+length them)) [me : them]
in allTasks (repeatn (length us) (get randomInt))
>>= \rs -> let gameSt = init_gameSt us rs
......@@ -30,7 +31,7 @@ play :: !(!Color,!String) !(Shared sds GameSt) -> Task (Color,String) | RWShared
play (me,name) game_st
= Hint name @>> updateSharedInformation [ligrettoEditor me] game_st
>>* [OnValue (withValue (\gameSt -> determine_winner gameSt
>>= \winner -> return (accolades winner me game_st >>| return winner)))]
`b` \winner -> Just (accolades winner me game_st >>| return winner)))]
show_winner :: Color (Shared sds GameSt) GameSt -> Task (Color,String) | RWShared sds
show_winner me game_st gameSt
......@@ -42,8 +43,8 @@ where
game_over :: !Color !(Shared sds GameSt) !GameSt -> Maybe (Task (Color,String)) | RWShared sds
game_over me game_st gameSt
= and_the_winner_is gameSt
>>= \{color,name} -> (let winner = (color,name)
in return (accolades winner me game_st >>| return winner))
`b` \{color,name} -> (let winner = (color,name)
in Just (accolades winner me game_st >>| return winner))
accolades :: !(!Color,!String) !Color !(Shared sds GameSt) -> Task GameSt | RWShared sds
accolades winner me game_st
......
......@@ -23,7 +23,6 @@ import
, iTasks.WF.Tasks.Interaction
, iTasks.WF.Combinators.Core
, iTasks.WF.Combinators.SDS
, iTasks.WF.Combinators.Overloaded
, iTasks.WF.Combinators.Common
// Distributed iTasks
, iTasks.Internal.Distributed.Domain
......
......@@ -254,14 +254,15 @@ determineAppPath world
= (currentDirectory </> (fst o hd o sortBy cmpFileTime) (zip2 batchfiles infos), world)
where
cmpFileTime (_,Ok {FileInfo | lastModifiedTime = x})
(_,Ok {FileInfo | lastModifiedTime = y}) = timeGm x > timeGm y
(_,Ok {FileInfo | lastModifiedTime = y}) = x > y
//By default, we use the modification time of the application executable as version id
determineAppVersion :: !FilePath!*World -> (!String,!*World)
determineAppVersion appPath world
# (res,world) = getFileInfo appPath world
| res =: (Error _) = ("unknown",world)
# tm = (fromOk res).lastModifiedTime
# (res,world) = getFileInfo appPath world
| res =: (Error _) = ("unknown",world)
# ts = timespecToStamp (fromOk res).lastModifiedTime
# (tm, world) = toLocalTime ts world
# version = strfTime "%Y%m%d-%H%M%S" tm
= (version,world)
......
......@@ -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.
*
......
implementation module iTasks.Extensions.CSVFile
import StdBool, StdList, System.FilePath, Text, Text.CSV, System.File, Data.Error
import iTasks, iTasks.Extensions.TextFile
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState, iTasks.Internal.TaskStore
importCSVFile :: !FilePath -> Task [[String]]
......@@ -27,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
......
implementation module iTasks.Extensions.DateTime
import iTasks.WF.Definition
import iTasks.WF.Tasks.Core
import iTasks.WF.Tasks.SDS
import iTasks.WF.Tasks.Interaction
import iTasks.WF.Combinators.Core
import iTasks.WF.Combinators.Common
import iTasks.SDS.Combinators.Common
import iTasks.WF.Combinators.Overloaded
import iTasks.SDS.Sources.System
from iTasks.Internal.Task import mkInstantTask
import iTasks.Internal.IWorld
......
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
implementation module iTasks.Extensions.Device.Features
import iTasks.SDS.Definition
import iTasks.SDS.Sources.Store
import iTasks
import iTasks.Internal.SDS
from iTasks.WF.Tasks.SDS import get, set
from iTasks.WF.Definition import class iTask
from iTasks.WF.Definition import :: Task, generic gEq, generic JSONDecode, generic JSONEncode, generic gText, generic gEditor, :: Editor, :: TaskId
from iTasks.Internal.Generic.Visualization import :: TextFormat(..)
from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode
from Data.Maybe import :: Maybe
from iTasks.WF.Tasks.Interaction import :: UpdateOption, updateInformation
from iTasks.WF.Combinators.Common import >>-
from iTasks.WF.Combinators.Overloaded import instance Functor Task, instance TMonad Task, class TMonad(..), class TApplicative, instance TApplicative Task
from iTasks.UI.Definition import :: Hint(..)
from iTasks.UI.Tune import class tune(..), @>>, instance tune Hint (Task a)
from Data.Functor import class Functor
import StdString
......
......@@ -10,6 +10,7 @@ from StdFunc import const, o
from TCPIP import :: Timeout
import System.OS
import iTasks.WF.Tasks.Core
from iTasks.WF.Definition import class iTask
from iTasks.Internal.Task import :: Task, generic gEq, generic JSONDecode, generic JSONEncode, generic gText, generic gEditor, :: Editor, :: TaskAttributes
from Data.Maybe import :: Maybe
......@@ -17,7 +18,6 @@ from iTasks.Extensions.User import class toUserConstraint(..), :: UserConstraint
from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode
from iTasks.Internal.Generic.Visualization import :: TextFormat(..)
import qualified iTasks.Extensions.User as U
from iTasks.WF.Combinators.Common import -&&-, >>-
from iTasks.SDS.Sources.System import currentDateTime
from iTasks.Extensions.User import currentUser, :: User(..), :: UserTitle, :: Role, :: UserId, assign, workerAttributes, :: Password, :: Username, workAs, :: Credentials{..}, users
from iTasks.UI.Definition import :: Title(..), :: Hint(..)
......@@ -45,7 +45,6 @@ from iTasks.Extensions.Distributed.Authentication import domainAuthServer, users
import Text
import iTasks.Extensions.Distributed.InteractionTasks
from StdList import ++
import iTasks.WF.Combinators.Overloaded
from Internet.HTTP import :: HTTPResponse{..}, :: HTTPMethod(..)
from Text.URI import :: URI{..}, parseURI
......
......@@ -30,14 +30,17 @@ where
((dynamicCompoundEditor $ editor p).CompoundEditor.onEdit dp event mbSt childSts vst)
onRefresh dp (p, new) st=:(p`, mbSt) childSts vst
| p === p` =
# (uiForOldP, vst) = (dynamicCompoundEditor $ editor p`).CompoundEditor.genUI 'Map'.newMap dp (Update new) vst
| isError uiForOldP = (liftError uiForOldP, vst)
# (uiForOldP, _, _) = fromOk uiForOldP
# (uiForNewP, vst) = (dynamicCompoundEditor $ editor p).CompoundEditor.genUI 'Map'.newMap dp (Update new) vst
| isError uiForNewP = (liftError uiForNewP, vst)
# (uiForNewP, newSt, newChildSts) = fromOk uiForNewP
| uiForOldP === uiForNewP =
appFst
(fmap $ appSnd3 \st -> (p, st))
((dynamicCompoundEditor $ editor p).CompoundEditor.onRefresh dp new mbSt childSts vst)
| otherwise =
appFst
(fmap $ \(ui, st, childSts) -> (ReplaceUI ui, (p, st), childSts))
((dynamicCompoundEditor $ editor p).CompoundEditor.genUI 'Map'.newMap dp (Update new) vst)
| otherwise = (Ok (ReplaceUI uiForNewP, (p, newSt), newChildSts), vst)
valueFromState (p, st) childSts
= (\val -> (p, val)) <$> (dynamicCompoundEditor $ editor p).CompoundEditor.valueFromState st childSts
......@@ -598,7 +601,6 @@ where
case (funcs, fst) of
((f, g) :: (a -> b, [b] -> c), _ :: a) = dynamic (g $ fromDynList (dynamic f) args)
_ = abort "corrupt dynamic editor value"
valueCorrespondingToList _ _ = abort "corrupt dynamic editor value"
fromDynList :: !Dynamic ![Dynamic] -> [b] | TC b
fromDynList mapFunc dyns = fromDynList` dyns []
......
......@@ -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
......@@ -145,7 +145,7 @@ selectFileTreeLazy multi root = accWorld (readDirectoryTree root (Just 1)) >>- \
where
mergeIn j newtree = foldTree \(i, t) cs->if (i == j) newtree (RNode t cs)
unstable a = treturn a @? \(Value a _)->Value a False
unstable a = return a @? \(Value a _)->Value a False
selOpt :: SelectOption (RTree (Int, (FilePath, MaybeOSError FileInfo))) (Int, (FilePath, MaybeOSError FileInfo))
selOpt = SelectInTree
......
implementation module iTasks.Extensions.TextFile
import StdBool, StdList, StdFile, StdArray, System.FilePath, Text, System.File, Data.Error, StdString
import StdBool, StdList, StdFile, StdArray, System.FilePath, Text, System.File, Data.Error, StdString, Data.Func
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState, iTasks.Internal.TaskStore
CHUNK_SIZE :== 1048576 // 1M
......@@ -37,14 +37,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
......
......@@ -18,7 +18,8 @@ from iTasks.Internal.Serialization import dynamicJSONEncode, dynamicJSONDecode
from iTasks.Internal.Distributed.Domain import Domain
from iTasks.UI.Editor.Common import emptyEditor
import iTasks.Internal.SDS
from Data.Maybe import fromMaybe, isNothing, fromJust, maybe, instance Functor Maybe
import Control.Applicative
import Data.Maybe
:: Source = Client Int InstanceNo
| Server Int InstanceNo
......@@ -132,8 +133,8 @@ where
notConnectedClientRequest [] = Nothing
notConnectedClientRequest [request:rest]
= case 'T'.split " " request of
["connect"] -> return (-1, rest)
["reconnect", id] -> return (toInt id, rest)
["connect"] -> pure (-1, rest)
["reconnect", id] -> pure (toInt id, rest)
_ -> case notConnectedClientRequest rest of
(Just (id, reqs)) -> (Just (id, [request:reqs]))
Nothing -> Nothing
......
......@@ -80,7 +80,7 @@ determineAppPath world
= (currentDirectory </> (fst o hd o sortBy cmpFileTime) (zip2 batchfiles infos), world)
where
cmpFileTime (_,Ok {FileInfo | lastModifiedTime = x})
(_,Ok {FileInfo | lastModifiedTime = y}) = timeGm x > timeGm y
(_,Ok {FileInfo | lastModifiedTime = y}) = x > y
destroyIWorld :: !*IWorld -> *World
destroyIWorld iworld=:{IWorld|world} = world
......
......@@ -44,7 +44,7 @@ wrapIWorldConnectionTask :: (ConnectionHandlersIWorld l r w) (sds () r w) -> Con
/**
* Create a task that finishes instantly
*/
mkInstantTask :: (TaskId *IWorld -> (MaybeError TaskException a,*IWorld)) -> Task a | iTask a
mkInstantTask :: (TaskId *IWorld -> (MaybeError TaskException a,*IWorld)) -> Task a
/**
* Apply a function on the task continuation of the task result
......@@ -60,4 +60,4 @@ wrapTaskContinuation tf val :== case val of
*/
unTask (Task t) :== t
nopTask :: Task a
nopTask :: Task a | iTask a
......@@ -112,7 +112,7 @@ where
= (toDyn <$> mbl, out, env)