
   0 | module System.UV.File
   1 | 
   2 | import Data.Buffer
   3 | import Data.Maybe
   4 | import System.UV.Loop
   5 | import System.UV.Pointer
   6 | import System.UV.Util
   7 | 
   8 | import public Data.Buffer.Indexed
   9 | import public Data.ByteString
  10 | 
  11 | import public System.UV.Raw.File
  12 | 
  13 | %default total
  14 | 
  15 | ||| A file handle.
  16 | public export
  17 | record File where
  18 |   constructor MkFile
  19 |   file : Int32
  20 | 
  21 | ||| File handle for standard input
  22 | export %inline
  23 | stdin : File
  24 | stdin = MkFile 0
  25 | 
  26 | ||| File handle for standard output
  27 | export %inline
  28 | stdout : File
  29 | stdout = MkFile 1
  30 | 
  31 | ||| File handle for standard err
  32 | export %inline
  33 | stderr : File
  34 | stderr = MkFile 2
  35 | 
  36 | export %inline
  37 | fsClose : HasIO io => (l : UVLoop) => File -> io ()
  38 | fsClose f = ignore . sync $ uv_fs_close l.loop f.file
  39 | 
  40 | export %inline
  41 | UVLoop => Resource File where
  42 |   release = fsClose
  43 | 
  44 | --------------------------------------------------------------------------------
  45 | -- File Errors
  46 | --------------------------------------------------------------------------------
  47 | 
  48 | public export
  49 | data UVFileError : Type where
  50 |   OpenError  : String -> UVError -> UVFileError
  51 |   ReadError  : String -> UVError -> UVFileError
  52 |   WriteError : String -> UVError -> UVFileError
  53 | 
  54 | export
  55 | Interpolation UVFileError where
  56 |   interpolate (OpenError s x)  = "Error when opening \{s}: \{errorMsg x}"
  57 |   interpolate (ReadError s x)  = "Error when reading \{s}: \{errorMsg x}"
  58 |   interpolate (WriteError s x) = "Error when writing to \{s}: \{errorMsg x}"
  59 | 
  60 | toFileError :
  61 |      {auto has : Has UVFileError es}
  62 |   -> (UVError -> UVFileError)
  63 |   -> Async [UVError] a
  64 |   -> Async es a
  65 | toFileError f = handleErrors (throw . f . project1)
  66 | 
  67 | --------------------------------------------------------------------------------
  68 | -- File Opening
  69 | --------------------------------------------------------------------------------
  70 | 
  71 | parameters {auto l   : UVLoop}
  72 |            {auto has : Has UVError es}
  73 | 
  74 |   fsOutcome : (Outcome es Int32 -> IO ()) -> Ptr Fs -> IO ()
  75 |   fsOutcome cb p = do
  76 |     n <- uv_fs_get_result p
  77 |     if n < 0
  78 |       then cb (Error . inject $ fromCode n)
  79 |       else cb (Succeeded n)
  80 | 
  81 |   fileOutcome : (Outcome es File -> IO ()) -> Ptr Fs -> IO ()
  82 |   fileOutcome cb = fsOutcome (cb . map MkFile)
  83 | 
  84 | parameters {auto l   : UVLoop}
  85 |            {auto has : Has UVFileError es}
  86 | 
  87 |   ||| Asynchronously opens a file.
  88 |   export
  89 |   fsOpen : String -> Flags -> Mode -> Async es File
  90 |   fsOpen path f m =
  91 |     toFileError (OpenError path) $ uvAsync $
  92 |       async (uv_fs_open l.loop path f.flags m.mode) . fileOutcome
  93 | 
  94 |   export %inline
  95 |   readOpen : String -> Async es File
  96 |   readOpen s = fsOpen s RDONLY 0
  97 | 
  98 |   export %inline
  99 |   writeOpen : String -> Async es File
 100 |   writeOpen s = fsOpen s (WRONLY <+> CREAT) 0o644
 101 | 
 102 |   export %inline
 103 |   appendOpen : String -> Async es File
 104 |   appendOpen s = fsOpen s (WRONLY <+> CREAT <+> APPEND) 0o644
 105 | 
 106 | --------------------------------------------------------------------------------
 107 | -- File Writing
 108 | --------------------------------------------------------------------------------
 109 | 
 110 | parameters {auto l   : UVLoop}
 111 |            {auto has : Has UVError es}
 112 | 
 113 |   writeOutcome : (Outcome es () -> IO ()) -> Ptr Fs -> IO ()
 114 |   writeOutcome cb = fsOutcome (cb . ignore)
 115 | 
 116 |   export
 117 |   writeBytesAt : File -> (offset : Int64) -> ByteString -> Async es ()
 118 |   writeBytesAt h offset bs =
 119 |     use1 (fromByteString bs) $ \cs =>
 120 |       uvAsync $ \cb => do
 121 |         async
 122 |           (uv_fs_write l.loop h.file cs (cast bs.size) offset)
 123 |           (writeOutcome cb)
 124 | 
 125 |   export %inline
 126 |   writeBytes : File -> ByteString -> Async es ()
 127 |   writeBytes h = writeBytesAt h (-1)
 128 | 
 129 |   ||| Writes all bytes to `stdout`.
 130 |   export %inline
 131 |   bytesOut : ByteString -> Async es ()
 132 |   bytesOut = writeBytes stdout
 133 | 
 134 |   ||| Write some text to `stdout`.
 135 |   export %inline
 136 |   putOut : String -> Async es ()
 137 |   putOut = bytesOut . fromString
 138 | 
 139 |   ||| Sink that writes all text to `stdout`, interpreting
 140 |   ||| every item as a single line
 141 |   export %inline
 142 |   putOutLn : String -> Async es ()
 143 |   putOutLn = putOut . (++ "\n")
 144 | 
 145 |   ||| Sink that printes values to `stdout` using their `Show`
 146 |   ||| implementation.
 147 |   export %inline
 148 |   printOut : Show a => a -> Async es ()
 149 |   printOut = putOut . show
 150 | 
 151 |   ||| Sink that printes values to `stdout` using their `Show`
 152 |   ||| implementation and putting every item on a single line.
 153 |   export %inline
 154 |   printOutLn : Show a => a -> Async es ()
 155 |   printOutLn = putOutLn . show
 156 | 
 157 |   ||| Writes all bytes to `stderr`.
 158 |   export %inline
 159 |   bytesErr : ByteString -> Async es ()
 160 |   bytesErr = writeBytes stderr
 161 | 
 162 |   ||| Write some text to `stderr`.
 163 |   export %inline
 164 |   putErr : String -> Async es ()
 165 |   putErr = bytesErr . fromString
 166 | 
 167 |   ||| Sink that writes all text to `stderr`, interpreting
 168 |   ||| every item as a single line
 169 |   export %inline
 170 |   putErrLn : String -> Async es ()
 171 |   putErrLn = putErr . (++ "\n")
 172 | 
 173 |   ||| Sink that printes values to `stderr` using their `Show`
 174 |   ||| implementation.
 175 |   export %inline
 176 |   printErr : Show a => a -> Async es ()
 177 |   printErr = putErr . show
 178 | 
 179 |   ||| Sink that printes values to `stderr` using their `Show`
 180 |   ||| implementation and putting every item on a single line.
 181 |   export %inline
 182 |   printErrLn : Show a => a -> Async es ()
 183 |   printErrLn = putErrLn . show
 184 | 
 185 | parameters {auto l   : UVLoop}
 186 |            {auto has : Has UVFileError es}
 187 | 
 188 |   export %inline
 189 |   writeFile : (path : String) -> Flags -> Mode -> ByteString -> Async es ()
 190 |   writeFile p fs m bs =
 191 |     use1 (fsOpen p (WRONLY <+> fs) m) $ \h =>
 192 |       toFileError (WriteError p) (writeBytes h bs)
 193 | 
 194 |   export %inline
 195 |   toFile : (path : String) -> ByteString -> Async es ()
 196 |   toFile p = writeFile p CREAT 0o644
 197 | 
 198 |   export %inline
 199 |   appendToFile : (path : String) -> ByteString -> Async es ()
 200 |   appendToFile p = writeFile p (CREAT <+> APPEND) 0o644
 201 | 
 202 | --------------------------------------------------------------------------------
 203 | -- File Reading
 204 | --------------------------------------------------------------------------------
 205 | 
 206 | parameters {auto l   : UVLoop}
 207 |            {auto has : Has UVError es}
 208 | 
 209 |   readOutcome : Ptr Bits8 -> (Outcome es ByteString -> IO ()) -> Ptr Fs -> IO ()
 210 |   readOutcome cs cb =
 211 |     fsOutcome {es} $ \case
 212 |       Succeeded res => toByteString cs (cast res) >>= cb . Succeeded
 213 |       Error err => cb (Error err)
 214 |       Canceled  => cb Canceled
 215 | 
 216 |   export
 217 |   readBytes : File -> Bits32 -> Async es ByteString
 218 |   readBytes f size =
 219 |     use1 (mallocPtrs Bits8 size) $ \cs =>
 220 |       uvAsync $ \cb => do
 221 |         async (uv_fs_read l.loop f.file cs size (-1)) (readOutcome cs cb)
 222 | 
 223 |   export
 224 |   readStdIn : Async es ByteString
 225 |   readStdIn = readBytes stdin 4096
 226 | 
 227 | parameters {auto l   : UVLoop}
 228 |            {auto has : Has UVFileError es}
 229 | 
 230 |   export
 231 |   readFile : (path : String) -> Bits32 -> Async es ByteString
 232 |   readFile path n =
 233 |     use1 (readOpen path) $ \h =>
 234 |       toFileError (ReadError path) (readBytes h n)
 235 | 
 236 |   export covering
 237 |   streamFileUntil :
 238 |        (path : String)
 239 |     -> Bits32
 240 |     -> (ByteString -> Async es (Maybe b))
 241 |     -> Async es (Maybe b)
 242 |   streamFileUntil {b} path size fun = use1 (readOpen path) go
 243 |     where
 244 |       go : File -> Async es (Maybe b)
 245 |       go h = do
 246 |         v  <- toFileError (ReadError path) (readBytes h size)
 247 |         if null v
 248 |            then pure Nothing
 249 |            else fun v >>= maybe (go h) (pure . Just)
 250 | 
 251 |   export covering
 252 |   streamFile :
 253 |        (path : String)
 254 |     -> Bits32
 255 |     -> (ByteString -> Async es ())
 256 |     -> Async es ()
 257 |   streamFile path n fun =
 258 |     ignore $ streamFileUntil {b = ()} path n (\x => fun x $> Nothing)
 259 | 
 260 |   export covering
 261 |   streamLinesUntil :
 262 |        (path : String)
 263 |     -> Bits32
 264 |     -> (List ByteString -> Async es (Maybe b))
 265 |     -> Async es (Maybe b)
 266 |   streamLinesUntil {b} path size fun = use1 (readOpen path) (go empty)
 267 |     where
 268 |       go : ByteString -> File -> Async es (Maybe b)
 269 |       go rem h = do
 270 |         v  <- toFileError (ReadError path) (readBytes h size)
 271 |         if null v
 272 |            then fun $ if null rem then [] else [rem]
 273 |            else
 274 |              let (ls,rem2) := accumLines rem v
 275 |               in fun ls >>= maybe (go rem2 h) (pure . Just)
 276 | 
 277 |   export covering
 278 |   streamLines :
 279 |        (path : String)
 280 |     -> Bits32
 281 |     -> (List ByteString -> Async es ())
 282 |     -> Async es ()
 283 |   streamLines path size fun =
 284 |     ignore $ streamLinesUntil {b = ()} path size (\xs => fun xs $> Nothing)
 285 | 
 286 |   export covering
 287 |   foldBytes :
 288 |        (path : String)
 289 |     -> Bits32
 290 |     -> (s -> ByteString -> s)
 291 |     -> s
 292 |     -> Async es s
 293 |   foldBytes {s} path size acc ini =
 294 |     use1 (readOpen path) (go ini)
 295 | 
 296 |     where
 297 |       go : s -> File -> Async es s
 298 |       go cur h = do
 299 |         v  <- toFileError (ReadError path) (readBytes h size)
 300 |         if null v then pure cur else go (acc cur v) h
 301 | 
 302 |   export covering
 303 |   foldLines :
 304 |        (path : String)
 305 |     -> Bits32
 306 |     -> (s -> ByteString -> s)
 307 |     -> s
 308 |     -> Async es s
 309 |   foldLines {s} path size acc ini =
 310 |     term <$> foldBytes path size accB (empty,ini)
 311 | 
 312 |     where
 313 |       term : (ByteString, s) -> s
 314 |       term (bs,s) = if null bs then s else acc s bs
 315 | 
 316 |       accB : (ByteString, s) -> ByteString -> (ByteString,s)
 317 |       accB (rem,cur) v =
 318 |         let (ls,rem2) := accumLines rem v
 319 |          in (rem2, foldl acc cur ls)
 320 |