Verified Commit 50c74881 authored by Camil Staps's avatar Camil Staps 🙂

Remove outdated, Windows-specific directory DataSources

parent 5b9975d7
Pipeline #41876 passed with stage
in 1 minute and 50 seconds
definition module DataSources.SharedFile
import System.FilePath, Data.SharedDataSource
sharedFile :: !FilePath !(String -> a) !(a -> String) -> Shared a *World
implementation module DataSources.SharedFile
import System._WinBase, System._Pointer, StdInt, StdArray, StdBool, StdFunc, System.FilePath, Data.SharedDataSource
import StdMisc
sharedFile :: !FilePath !(String -> a) !(a -> String) -> Shared a *World
sharedFile path str2b b2str = createBasicDataSource "sharedFile" path mkOps id const
where
mkOps world
# (heap, world) = getProcessHeap world
// check NULL
# (handle, world) = createFileA
(packString path)
(GENERIC_READ + GENERIC_WRITE)
(FILE_SHARE_READ + FILE_SHARE_WRITE)
NULL
OPEN_ALWAYS
FILE_ATTRIBUTE_NORMAL
NULL
world
| handle == INVALID_HANDLE_VALUE = abort "create: invalid handle"
= (ops heap handle, world)
ops heap handle =
{ read = read
, write = write
, getVersion = getVersion
, lock = lock
, lockExcl = lockExcl
, unlock = unlock
, close = close
, addObserver = addObserver
}
where
read world
# (len, world) = getFileSize handle (packInt 0) world
// check INVALID_FILE_SIZE
# (pBuffer, world) = heapAlloc heap 0 len world
// check NULL
# (ok, world) = readFile handle pBuffer len (packInt 0) NULL world
| not ok = (Error "shared file: read error", world)
#! str = derefCharArray pBuffer len
# (ok, world) = heapFree heap 0 pBuffer world
// check ok
# (ver, world) = getVersion world
| isError ver = (liftError ver, world)
= (Ok (str2b str, fromOk ver), world)
write b world
# str = b2str b
# len = size str
# (pBuffer, world) = heapAlloc heap 0 len world
// check NULL
# pBuffer = writeCharArray pBuffer str
# (overlapped, world) = heapAlloc heap HEAP_ZERO_MEMORY OVERLAPPED_SIZE_BYTES world
// check NULL
# (ok, world) = writeFile handle pBuffer len (packInt 0) overlapped world
| not ok = (Error "shared file: write error", world)
# (ok, world) = heapFree heap 0 overlapped world
// check ok
# (ok, world) = heapFree heap 0 pBuffer world
// check ok
# (ok, world) = setEndOfFile handle world
| not ok = (Error "shared file: set EOF error", world)
= (Ok (), world)
getVersion world
# (len, world) = getFileSize handle (packInt 0) world
// check INVALID_FILE_SIZE
= (Ok len, world)
lock = lock` 0
lockExcl = lock` LOCKFILE_EXCLUSIVE_LOCK
lock` flags world
# (overlapped, world) = heapAlloc heap HEAP_ZERO_MEMORY OVERLAPPED_SIZE_BYTES world
// check NULL
# (ok, world) = lockFileEx
handle
flags
NULL
0
0xffff0000
overlapped
world
| not ok = abort "lock file error"
# (ok, world) = heapFree heap 0 overlapped world
// check ok
= world
addObserver obs world = world
wait world
# world = close (unlock world)
= world
unlock world
# (ok, world) = unlockFile handle 0 0 0 0xffff0000 world
| not ok = abort "unlock error"
= world
close world
# (ok, world) = closeHandle handle world
| not ok = abort "close error"
= world
definition module DataSources.SharedMemory
import Data.SharedDataSource
:: Memory :== Int
sharedMemory :: !a !*envC -> (!Shared a *envS, !*envC) | MemoryEnv envC & MemoryEnv envS
class MemoryEnv env
where
accMemory :: !(*Memory -> (!a,!*Memory)) !*env -> (!a,!*env)
instance MemoryEnv World
implementation module DataSources.SharedMemory
import System._WinBase, System._Pointer, System._Unsafe, StdInt, StdTuple, StdString, StdArray, StdBool, StdFunc, System.FilePath, Data.SharedDataSource, dynamic_string
import StdMisc
/**
* |--------------------------------------------|
* | size | value ptr | version | observer list |
* |--------------------------------------------|
* | | |-------------------|
* | -------------> | observer 0 | next |
* V |-------------------|
* |----------------------| |
* | dynamic value string | --> ...
* |----------------------|
* <-------- size -------->
*/
sharedMemory :: !a !*envC -> (!Shared a *envS, !*envC) | MemoryEnv envC & MemoryEnv envS
sharedMemory v world
# (heap, world) = getProcessHeap world
# initStr = copy_to_string v
# sStr = size initStr
# (mutx, world) = createMutexA NULL False NULL world
// check ok
# (iptr, world) = heapAlloc heap 0 (INT_SIZE * 4) world
# (vptr, world) = heapAlloc heap 0 sStr world
# vptr = writeCharArray vptr initStr
# iptr = writeIntElemOffset iptr 0 sStr // init size of dynamic string
# iptr = writeIntElemOffset iptr 1 vptr // init pointer to dynamic string
# iptr = writeIntElemOffset iptr 2 0 // init version number
# iptr = writeIntElemOffset iptr 3 NULL // init linked list of observers
= (createBasicDataSource "sharedMemory" (toString iptr) (mkOps heap mutx iptr) id const, world)
where
get str = fst (copy_from_string {c \\ c <-: str})
putback v _ = copy_to_string v
mkOps heap mutx ptr env =
({ read = read
, write = write
, getVersion = getVersion
, lock = lock
, lockExcl = lockExcl
, unlock = unlock
, close = close
, addObserver = addObserver
}, env)
where
read world
# (sStr,ptr) = readIntElemOffsetP ptr 0
# (vptr,ptr) = readIntElemOffsetP ptr 1
# (ver,ptr) = readIntElemOffsetP ptr 2
# str = derefCharArray vptr sStr
# world = forceEvalPointer ptr world
# world = forceEval str world
= (Ok (fst (copy_from_string {c \\ c <-: str}), ver), world)
write b world
# dstr = copy_to_string b
# (vptr,ptr) = readIntElemOffsetP ptr 1
# (ok, world) = heapFree heap 0 vptr world
| not ok = (Error "writing to shared memory: error freeing memory", world)
# sStr = size dstr
# (vptr, world) = heapAlloc heap 0 sStr world
| vptr == NULL = (Error "writing to shared memory: error allocating memory", world)
# vptr = writeCharArray vptr dstr
# ptr = writeIntElemOffset ptr 0 sStr
# ptr = writeIntElemOffset ptr 1 vptr
// increase version number
# ver = readIntElemOffset ptr 2
# ptr = writeIntElemOffset ptr 2 (inc ver)
// notify observers and empty list
# (wptr,ptr) = readIntElemOffsetP ptr 3
# world = notifyObservers wptr world
# ptr = writeIntElemOffset ptr 3 NULL
= (Ok (), forceEvalPointer ptr world)
where
notifyObservers :: !Pointer !*env -> *env
notifyObservers wptr world
| wptr == NULL = world
# obs = readIntElemOffset wptr 0
# (_, world) = setEvent obs world
# next = readIntElemOffset wptr 1
# world = notifyObservers next world
# (ok, world) = heapFree heap 0 wptr world
| not ok = abort "notifyWaiters: error freeing heap"
= world
getVersion world
= (Ok (readIntElemOffset ptr 2), world)
addObserver observer world
# (nptr, world) = heapAlloc heap 0 (INT_SIZE * 2) world
# optr = readIntElemOffset ptr 3
# nptr = writeIntElemOffset nptr 0 observer
# nptr = writeIntElemOffset nptr 1 optr
# ptr = writeIntElemOffset ptr 3 nptr
= forceEvalPointer ptr world
lock = lock`
lockExcl = lock`
lock` world
# (r, world) = waitForSingleObject mutx INFINITE world
| r <> WAIT_OBJECT_0 = abort "shared memory: error getting lock"
= world
unlock world
# (ok, world) = releaseMutex mutx world
| not ok = abort "shared memory: error releasing lock"
= world
close world = world
instance MemoryEnv World
where
accMemory accFunc env
# (a, mem) = accFunc 0
= (a,env)
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment