1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731

{-# LANGUAGE QuasiQuotes #-}

module Sqlitefs where

import Builder
import Control.Exception (Exception (displayException), catch)
import Data.ByteString qualified as B
import Data.ByteString qualified as ByteString
import Data.Error.Tree (errorTreeContext)
import Data.Graph (Tree)
import Data.IORef
import Data.List qualified as List
import Data.Text qualified as Text
import Data.Time.Clock.POSIX qualified as Posix
import Data.Tree qualified as Tree
import Database.SQLite.Simple (Connection, NamedParam ((:=)))
import Database.SQLite.Simple qualified as Sqlite
import Database.SQLite.Simple.QQ (sql)
import Divisive
import Hedgehog (Gen, Range)
import Hedgehog qualified as Hedge
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Label
import MyLabel
import MyPrelude
import Parse qualified
import System.Directory (XdgDirectory (..), createDirectoryIfMissing, getXdgDirectory)
import System.Environment (getArgs, withArgs)
import System.Exit (exitFailure)
import System.Fuse hiding (ReadOnly, ReadWrite, WriteOnly)
import System.Fuse qualified as Fuse
import System.IO (hPutStrLn, stderr)
import System.Posix (ByteCount, DeviceID, EpochTime, FileMode, FileOffset, defaultFileFlags, groupWriteMode, ownerWriteMode)
import System.Posix.Files
  ( groupReadMode,
    otherReadMode,
    ownerReadMode,
  )
import Test
import Test.Hspec qualified as Hspec
import Test.Hspec.Hedgehog (hedgehog)

-- TODO: reading the content into the state struct seems to be the only way
-- to assert the file is still readable from its fd even if the row is deleted
-- in-between open and read.
type State = T2 "content" ByteString "readWrite" ReadWrite

-- | Depending on whether the file system is mounted read-only or read-write,
-- and if the table is a view or not, we can determine the read/write mode.
data EnvReadOnly = EnvReadOnly | EnvReadWrite

data ReadWrite
  = WriteOnly
  | ReadWrite
  | ReadOnly ReadOnlyReason
  deriving stock (Show, Eq)

data ReadOnlyReason = IsView | ModeRequested
  deriving stock (Show, Eq)

-- | Parse command line arguments to extract database path
-- Supports: program [options] mountpoint [-- dbpath] or program [options] mountpoint dbpath
parseArgs :: [String] -> IO String
parseArgs args = case findDashDash args of
  Just dashIndex -> 
    case drop (dashIndex + 1) args of
      (dbPath : _) -> pure dbPath
      [] -> do
        putStderrLn "Error: -- found but no database path argument follows"
        exitFailure
  Nothing ->
    case reverse (filter (not . isPrefixOf "-") args) of
      (dbPath : _) -> pure dbPath
      [] -> do
        putStderrLn "Error: No database path provided. Usage: sqlitefs [options] mountpoint [-- dbpath] or sqlitefs [options] mountpoint dbpath"
        exitFailure
  where
    findDashDash :: [String] -> Maybe Int
    findDashDash xs = List.findIndex (== "--") xs
    
    isPrefixOf :: String -> String -> Bool
    isPrefixOf [] _ = True
    isPrefixOf _ [] = False
    isPrefixOf (x:xs) (y:ys) = x == y && isPrefixOf xs ys

-- | Filter out database path and -- separator from arguments for FUSE
filterDatabasePath :: [String] -> String -> [String]
filterDatabasePath args dbPath = filter shouldKeep args
  where
    shouldKeep arg = arg /= dbPath && arg /= "--"

main :: IO ()
main = do
  args <- getArgs
  databasePath <- parseArgs args
  let filteredArgs = filterDatabasePath args databasePath
  putStderrLn $ "Using database path: " <> showToText databasePath
  withSqlite databasePath $ \conn -> do
    let tableName = "files"

    envReadOnly <-
      Sqlite.queryNamed conn "SELECT name, type FROM sqlite_schema WHERE name = :name" [":name" := (tableName :: Text)] >>= \case
        [] -> do
          putStderrLn [fmt|No table named '{tableName}' exists, creating it|]
          createTestTable conn
          putStderrLn [fmt|Table '{tableName}' created successfully, mounting read-write|]
          -- Enable WAL mode for better concurrency in read-write mode
          Sqlite.execute_ conn "PRAGMA journal_mode=WAL" `Control.Exception.catch` \(e :: Sqlite.SQLError) -> do
            putStderrLn [fmt|Warning: Failed to enable WAL mode: {displayException e}|]
            putStderrLn "Continuing with default journal mode"
          pure EnvReadWrite
        ((name, type_) : _ :: [(Text, Text)]) -> do
          -- TODO: also detect here if the columns we want are there
          putStderrLn [fmt|Table "{name}" exists and is a {type_}|]

          -- if type is 'view', we should enforce read-only mode for now
          case type_ of
            "view" -> do
              putStderrLn [fmt|Table "{name}" is a view, mounting read-only|]
              pure EnvReadOnly
            "table" -> do
              putStderrLn [fmt|Table "{name}" is a table, mounting read-write|]
              -- Enable WAL mode for better concurrency in read-write mode
              Sqlite.execute_ conn "PRAGMA journal_mode=WAL" `Control.Exception.catch` \(e :: Sqlite.SQLError) -> do
                putStderrLn [fmt|Warning: Failed to enable WAL mode: {displayException e}|]
                putStderrLn "Continuing with default journal mode"
              pure EnvReadWrite
            other -> do
              putStderrLn [fmt|Table "{name}" is of unknown type "{other}", mounting read-only|]
              pure EnvReadOnly

    withArgs filteredArgs $ fuseMain
      defaultFuseOps'
        { fuseGetFileStat = myFuseGetFileStat conn envReadOnly,
          fuseOpen = myFuseOpen conn envReadOnly,
          fuseRead = myFuseRead conn,
          fuseCreateDevice = myFuseCreateDevice conn,
          fuseSetFileTimes = myFuseSetFileTimes conn,
          fuseSynchronizeFile = myFuseSynchronizeFile conn,
          fuseFlush = myFuseFlush conn,
          fuseWrite = myFuseWrite conn,
          fuseRemoveLink = myFuseRemoveLink conn,
          fuseRelease = myFuseRelease conn,
          fuseOpenDirectory = myFuseOpenDirectory conn,
          fuseReadDirectory = myFuseReadDirectory conn,
          fuseReleaseDirectory = myFuseReleaseDirectory conn
        }
      defaultExceptionHandler

myFuseGetFileStat :: Connection -> EnvReadOnly -> FilePath -> IO (Either Errno FileStat)
myFuseGetFileStat conn envReadOnly path = do
  putStderrLn $ "fuseGetFileStat: " <> showToText path
  ctx <- getFuseContext

  -- Special case for root directory
  if path == "/"
    then do
      putStderrLn "fuseGetFileStat: root directory"
      pure $ Right $ fileStat envReadOnly 0 Directory ctx
    else do
      -- Check if this is a directory by looking for nested files
      queryNamedWith
        conn
        [sql|
          SELECT filecontent, COALESCE((SELECT 1 FROM files WHERE filename LIKE :path || '/%' LIMIT 1), 0) as has_nested
          FROM files
          WHERE filename = :path
          LIMIT 1
        |]
        [":path" := (List.stripPrefix "/" path & fromMaybe path)]
        ( do
            content <- columnIdx 0 "filecontent" <&> sqlDataToBytestring
            hasNested <- columnIdx 1 "has_nested" >>> sqlBool
            pure (content, hasNested)
        )
        >>= \case
          [] -> do
            putStderrLn $ "fuseGetFileStat: file not found: " <> showToText path
            pure $ Left eNOENT
          ((content, hasNested) : _) -> do
            putStderrLn $ "fuseGetFileStat: file found: " <> showToText path
            let entryType = if hasNested then Directory else RegularFile
            pure $ Right $ fileStat envReadOnly (fromIntegral $ ByteString.length content) entryType ctx

myFuseOpen :: Connection -> EnvReadOnly -> FilePath -> OpenMode -> OpenFileFlags -> IO (Either Errno State)
myFuseOpen conn envReadOnly path mode flags = do
  putStderrLn $ "fuseOpen: " <> showToText (path, mode, flags)
  when
    ( flags
        { -- ignore nonBlock
          nonBlock = False
        }
        /= defaultFileFlags
    )
    $ do
      putStderrLn $ "WARN fuseOpen: no open flags supported yet, got: " <> showToText flags

  readWrite <- case envReadOnly of
    EnvReadWrite -> case mode of
      Fuse.ReadOnly -> do
        putStderrLn "fuseOpen: opening file in read-only mode on read-write file system"
        pure $ ReadOnly ModeRequested
      Fuse.WriteOnly -> do
        putStderrLn "fuseOpen: opening file in write-only mode on read-write file system"
        pure WriteOnly
      Fuse.ReadWrite -> do
        putStderrLn "fuseOpen: opening file in read-write mode on read-write file system"
        pure ReadWrite
    EnvReadOnly -> case mode of
      Fuse.ReadOnly -> do
        putStderrLn "fuseOpen: opening file in read-only mode on read-only file system"
        pure $ ReadOnly IsView
      Fuse.WriteOnly -> do
        putStderrLn "fuseOpen: cannot open file in write-only mode on read-only file system"
        pure $ ReadOnly IsView
      Fuse.ReadWrite -> do
        putStderrLn "fuseOpen: cannot open file in read-write mode on read-only file system"
        pure $ ReadOnly IsView

  queryNamedWith
    conn
    "SELECT filecontent FROM files WHERE filename = :path"
    [":path" := (List.stripPrefix "/" path & fromMaybe path)]
    (columnIdx 0 "filecontent" <&> sqlDataToBytestring)
    >>= \case
      [] -> do
        putStderrLn $ "fuseOpen: file not found, creating: " <> showToText path
        -- Create empty file when opening non-existent file for writing
        case readWrite of
          ReadOnly _ -> do
            putStderrLn $ "fuseOpen: cannot create file in read-only mode: " <> showToText path
            pure $ Left eNOENT
          _ -> do
            -- Create empty file in database
            Sqlite.executeNamed
              conn
              "INSERT INTO files (filename, filecontent) VALUES (:path, :content) ON CONFLICT(filename) DO UPDATE SET filecontent = :content"
              [":path" := (List.stripPrefix "/" path & fromMaybe path), ":content" := B.empty]
            putStderrLn $ "fuseOpen: created empty file: " <> showToText path
            pure $ Right $ t2 #content B.empty #readWrite readWrite
      (x : _) -> do
        putStderrLn $ "fuseOpen: file found: " <> showToText path
        pure $ Right $ t2 #content x #readWrite readWrite

myFuseRead :: Connection -> FilePath -> State -> ByteCount -> FileOffset -> IO (Either Errno ByteString)
myFuseRead _ path state byteCount offset = do
  -- TODO: ideally, we'd use the BLOB API here to read only the requested bytes from the file system
  putStderrLn ("fuseRead: " <> showToText (path, byteCount, offset))
  pure $ Right $ B.take (fromIntegral byteCount) $ B.drop (fromIntegral offset) state.content

myFuseSetFileTimes :: Connection -> FilePath -> EpochTime -> EpochTime -> IO Errno
myFuseSetFileTimes _conn path _atime _mtime = do
  putStderrLn $ "fuseSetFileTimes: " <> showToText (path, _atime, _mtime)
  pure eOK

myFuseCreateDevice :: Connection -> FilePath -> EntryType -> FileMode -> DeviceID -> IO Errno
myFuseCreateDevice conn path entryType mode dev = do
  case entryType of
    RegularFile -> do
      putStderrLn $ "fuseCreateDevice: creating regular file: " <> showToText (path, mode, dev)
      Sqlite.executeNamed
        conn
        "INSERT INTO files (filename, filecontent) VALUES (:path, :content) ON CONFLICT(filename) DO UPDATE SET filecontent = :content"
        [":path" := (List.stripPrefix "/" path & fromMaybe path), ":content" := B.empty]
      pure eOK
    _ -> do
      putStderrLn $ "fuseCreateDevice: cannot create device of type " <> showToText entryType <> " at path: " <> showToText path
      pure eNOSYS

myFuseSynchronizeFile :: Connection -> FilePath -> SyncType -> IO Errno
myFuseSynchronizeFile _conn path _syncType = do
  putStderrLn $ "fuseSynchronizeFile: " <> showToText (path)
  pure eOK

myFuseFlush :: Connection -> FilePath -> State -> IO Errno
myFuseFlush _conn path state = do
  putStderrLn $ "fuseFlush: " <> showToText (path, state)
  pure eOK

myFuseRelease :: Connection -> FilePath -> State -> IO ()
myFuseRelease _conn path state = do
  putStderrLn $ "fuseRelease: " <> showToText (path, state)
  pure ()

myFuseWrite :: Connection -> FilePath -> State -> ByteString -> FileOffset -> IO (Either Errno ByteCount)
myFuseWrite conn path state bs offset = do
  putStderrLn $ "fuseWrite: " <> showToText (path, state, bs, offset)

  case state.readWrite of
    ReadOnly reason -> do
      putStderrLn [fmt|fuseWrite: cannot write to read-only file, reason: {show reason}|]
      pure $ Left eROFS
    WriteOnly -> write
    ReadWrite -> write
  where
    write :: IO (Either Errno ByteCount)
    write = do
      -- putStderrLn $ "fuseWrite: writing " <> showToText (B.length bs) <> " bytes at offset " <> showToText offset

      -- TODO: we are writing the whole file here, instead we should use the  blob API to write only the requested bytes.
      let newContent =
            buildBytes
              (dt3 #before bytesB #new bytesB #after bytesB)
              ( t3
                  #before
                  (B.take (fromIntegral offset) state.content)
                  #new
                  bs
                  #after
                  (B.drop (fromIntegral offset) state.content)
              )

      -- TODO: catch sqlite errors and return appropriate Errno
      Sqlite.executeNamed
        conn
        "INSERT INTO files (filename, filecontent) VALUES (:path, :newContent) ON CONFLICT(filename) DO UPDATE SET filecontent = :newContent"
        [":newContent" := newContent, ":path" := (List.stripPrefix "/" path & fromMaybe path)]

      pure $ Right (fromIntegral $ ByteString.length bs)

myFuseOpenDirectory :: Connection -> FilePath -> IO Errno
myFuseOpenDirectory _conn fp = do
  putStderrLn $ "fuseOpenDirectory: " <> showToText fp
  if
    | fp == "" -> pure eNOENT
    | fp == "/" -> pure eOK
    | otherwise -> do
        -- check that we have any files which have the directory as prefix, with a trailing slash, otherwise return eNOENT
        queryNamedWith
          _conn
          "SELECT filename FROM files WHERE filename LIKE :path || '/%' LIMIT 1"
          [":path" := (List.stripPrefix "/" fp & fromMaybe fp)]
          (pure ())
          >>= \case
            [] -> do
              putStderrLn $ "fuseOpenDirectory: no files found for path: " <> showToText fp
              pure eNOENT
            _ -> do
              putStderrLn $ "fuseOpenDirectory: found files for path: " <> showToText fp
              pure eOK

myFuseRemoveLink :: Connection -> FilePath -> IO Errno
myFuseRemoveLink _conn path = do
  putStderrLn $ "fuseRemoveLink: " <> showToText path
  Sqlite.executeNamed
    _conn
    "DELETE FROM files WHERE filename = :path"
    [":path" := (List.stripPrefix "/" path & fromMaybe path)]
  pure eOK

myFuseReadDirectory :: Connection -> FilePath -> IO (Either Errno [(FilePath, FileStat)])
myFuseReadDirectory _conn fp = do
  putStderrLn $ "fuseReadDirectory: " <> showToText fp
  ctx <- getFuseContext
  -- We do the prefix match like in fuseOpenDirectory, but we also need to
  -- ensure that we only return files that are direct children of the directory,
  -- i.e. that do not have a slash in the name after the prefix.
  let pathParam = case fp of
        "/" -> ""  -- For root directory, use empty string
        _   -> List.stripPrefix "/" fp & fromMaybe fp
  
  queryNamedWith
    _conn
    [sql|
      SELECT filename, filecontent, COALESCE((SELECT 1 FROM files WHERE filename LIKE f.filename || '/%' LIMIT 1), 0) as has_nested
      FROM files f
      WHERE CASE 
        WHEN :path = '' THEN 
          -- Root directory: show files without slashes AND directories (files with exactly one slash)
          (filename NOT LIKE '%/%' OR (filename LIKE '%/%' AND filename NOT LIKE '%/%/%'))
        ELSE 
          -- Subdirectory: original logic
          ((filename = :path OR filename LIKE :path || '/%') AND filename NOT LIKE :path || '/%/%')
        END
      ORDER BY filename
    |]
    [":path" := pathParam]
    ( do
        name <- columnIdx 0 "filename" <&> sqlDataToText <&> textToString
        content <- columnIdx 1 "filecontent" <&> sqlDataToBytestring
        hasNestedFiles <- columnIdx 2 "has_nested" >>> sqlBool
        pure $ do
          let entryType = if hasNestedFiles then Directory else RegularFile
          ( name,
            fileStat
              EnvReadWrite
              (fromIntegral $ ByteString.length content)
              entryType
              ctx
            )
    )
    >>= \case
      [] -> do
        putStderrLn $ "fuseReadDirectory: no files found for path: " <> showToText fp
        pure $ Left eNOENT
      rows -> do
        putStderrLn $ "fuseReadDirectory: found files for path: " <> showToText fp
        pure $ Right rows

myFuseReleaseDirectory :: Connection -> FilePath -> IO Errno
myFuseReleaseDirectory _conn path = do
  putStderrLn $ "fuseReleaseDirectory: " <> showToText path
  pure eOK

fileStat :: EnvReadOnly -> FileOffset -> EntryType -> FuseContext -> FileStat
fileStat envReadOnly fileSize entryType ctx =
  FileStat
    { statEntryType = entryType,
      statFileMode =
        foldr1
          unionFileModes
          ( case envReadOnly of
              EnvReadWrite -> [ownerReadMode, ownerWriteMode, groupReadMode, groupWriteMode, otherReadMode]
              EnvReadOnly -> [ownerReadMode, groupReadMode, otherReadMode]
          ),
      statLinkCount = 0,
      statFileOwner = fuseCtxUserID ctx,
      statFileGroup = fuseCtxGroupID ctx,
      statSpecialDeviceID = 0,
      statFileSize = fileSize,
      statBlocks = fromIntegral fileSize `div` 512,
      statAccessTime = 0,
      statModificationTime = 0,
      statStatusChangeTime = 0
    }

withSqlite :: String -> (Sqlite.Connection -> IO a) -> IO a
withSqlite fileName inner = Sqlite.withConnection fileName $ \conn -> do
  Sqlite.setTrace conn (Just (\msg -> hPutStrLn stderr (textToString [fmt|{fileName}: {msg}|])))
  -- Set busy timeout for better concurrent access handling
  Sqlite.execute_ conn "PRAGMA busy_timeout = 5000"
  inner conn

queryNamedWith :: Sqlite.Connection -> Sqlite.Query -> [NamedParam] -> Parse.Parse [Sqlite.SQLData] a -> IO [a]
queryNamedWith conn qry params parse = do
  rows <- Sqlite.queryNamed @[Sqlite.SQLData] conn qry params
  Parse.runParse "parse errors" (Parse.multiple parse) rows
    & first (errorTreeContext [fmt|Error parsing query result|])
    & unwrapIOErrorTree

columnIdx :: Natural -> Text -> Parse.Parse [Sqlite.SQLData] Sqlite.SQLData
columnIdx idx columnName = Parse.mkParsePushContext [fmt|[column {idx} ({columnName})|] $ \from -> case from List.!? (fromIntegral @_ @Int idx) of
  Nothing -> Left [fmt|Column with index {idx} does not exist (out of bounds)|]
  Just a -> Right a

sqlDataToBytestring :: Sqlite.SQLData -> ByteString
sqlDataToBytestring = \case
  Sqlite.SQLBlob bs -> bs
  Sqlite.SQLText txt -> textToBytesUtf8 txt
  Sqlite.SQLInteger i -> buildBytes int64DecimalB i
  Sqlite.SQLFloat f -> buildBytes doubleDecimalB f
  Sqlite.SQLNull -> B.empty

sqlDataToText :: Sqlite.SQLData -> Text
sqlDataToText s = s & sqlDataToBytestring & bytesToTextUtf8Lenient

sqlBool :: Parse.Parse Sqlite.SQLData Bool
sqlBool = Parse.mkParseNoContext $ \case
  Sqlite.SQLInteger 0 -> Right False
  Sqlite.SQLInteger 1 -> Right True
  s -> Left [fmt|Expected boolean (0 or 1), got {prettySqlData s}|]

-- do length restriction on the length of output, put … if the string is too long
prettySqlData :: Sqlite.SQLData -> Text
prettySqlData s =
  s & sqlDataToBytestring & bytesToTextUtf8Lenient & \txt ->
    if Text.length txt > 100
      then Text.take 100 txt <> "…"
      else txt

-- | Empty \/ default versions of the FUSE operations.
defaultFuseOps' :: FuseOperations State
defaultFuseOps' =
  FuseOperations
    { fuseGetFileStat = \path -> do
        putStderrLn $ "fuseGetFileStat not implemented: " <> showToText path
        pure (Left eNOSYS),
      fuseReadSymbolicLink = \path -> do
        putStderrLn $ "fuseReadSymbolicLink not implemented: " <> showToText path
        pure (Left eNOSYS),
      fuseCreateDevice = \path entryType mode dev -> do
        putStderrLn $ "fuseCreateDevice not implemented" <> showToText (path, entryType, mode, dev)
        pure eNOSYS,
      fuseCreateDirectory = \path mode -> do
        putStderrLn $ "fuseCreateDirectory not implemented: " <> showToText (path, mode)
        pure eNOSYS,
      fuseRemoveLink = \path -> do
        putStderrLn $ "fuseRemoveLink not implemented: " <> showToText path
        pure eNOSYS,
      fuseRemoveDirectory = \path -> do
        putStderrLn $ "fuseRemoveDirectory not implemented: " <> showToText path
        pure eNOSYS,
      fuseCreateSymbolicLink = \target linkPath -> do
        putStderrLn $ "fuseCreateSymbolicLink not implemented: " <> showToText (target, linkPath)
        pure eNOSYS,
      fuseRename = \oldPath newPath -> do
        putStderrLn $ "fuseRename not implemented: " <> showToText (oldPath, newPath)
        pure eNOSYS,
      fuseCreateLink = \target linkPath -> do
        putStderrLn $ "fuseCreateLink not implemented: " <> showToText (target, linkPath)
        pure eNOSYS,
      fuseSetFileMode = \path mode -> do
        putStderrLn $ "fuseSetFileMode not implemented: " <> showToText (path, mode)
        pure eNOSYS,
      fuseSetOwnerAndGroup = \path owner group -> do
        putStderrLn $ "fuseSetOwnerAndGroup not implemented: " <> showToText (path, owner, group)
        pure eNOSYS,
      fuseSetFileSize = \path size -> do
        putStderrLn $ "fuseSetFileSize not implemented: " <> showToText (path, size)
        pure eNOSYS,
      fuseSetFileTimes = \path atime mtime -> do
        putStderrLn $ "fuseSetFileTimes not implemented: " <> showToText (path, atime, mtime)
        pure eNOSYS,
      fuseOpen = \path mode flags -> do
        putStderrLn $ "fuseOpen not implemented: " <> showToText (path, mode, flags)
        pure (Left eNOSYS),
      fuseRead = \path state byteCount offset -> do
        putStderrLn $ "fuseRead not implemented: " <> showToText (path, state, byteCount, offset)
        pure (Left eNOSYS),
      fuseWrite = \path state bs offset -> do
        putStderrLn $ "fuseWrite not implemented: " <> showToText (path, state, bs, offset)
        pure (Left eNOSYS),
      fuseGetFileSystemStats = \path -> do
        putStderrLn $ "fuseGetFileSystemStats not implemented: " <> showToText path
        pure (Left eNOSYS),
      fuseFlush = \path state -> do
        putStderrLn $ "fuseFlush not implemented: " <> showToText (path, state)
        pure eOK,
      fuseRelease = \path state -> do
        putStderrLn $ "fuseRelease not implemented: " <> showToText (path, state)
        pure (),
      fuseSynchronizeFile = \path _syncType -> do
        putStderrLn $ "fuseSynchronizeFile not implemented: " <> showToText (path)
        pure eNOSYS,
      fuseOpenDirectory = \path -> do
        putStderrLn $ "fuseOpenDirectory not implemented: " <> showToText path
        pure eNOSYS,
      fuseReadDirectory = \path -> do
        putStderrLn $ "fuseReadDirectory not implemented: " <> showToText path
        pure (Left eNOSYS),
      fuseReleaseDirectory = \path -> do
        putStderrLn $ "fuseReleaseDirectory not implemented: " <> showToText path
        pure eNOSYS,
      fuseSynchronizeDirectory = \path _syncType -> do
        putStderrLn $ "fuseSynchronizeDirectory not implemented: " <> showToText (path)
        pure eNOSYS,
      fuseAccess = \path mode -> do
        putStderrLn $ "fuseAccess not implemented: " <> showToText (path, mode)
        pure eNOSYS,
      fuseInit = do
        putStderrLn "FUSE_INIT_COMPLETE"
        pure (),
      fuseDestroy = do
        putStderrLn "fuseDestroy not implemented"
        pure ()
    }

data Sqlite = Sqlite
  { connection :: Connection,
    hasFailed :: IORef Bool
  }

withMemorySqlite :: (Connection -> IO ()) -> SpecWith Sqlite -> Spec
withMemorySqlite createTable spec = do
  hasFailed <- Hspec.runIO $ newIORef False
  Test.aroundAll
    ( \act ->
        withSqlite
          ":memory:"
          ( \conn -> do
              createTable conn
              act $ Sqlite {connection = conn, hasFailed}
          )
    )
    $ Test.afterAll
      ( \sqlite -> do
          readIORef hasFailed >>= \case
            True -> do
              -- get temporary file to dump into
              tmpFile <- do
                let tmpl = dt2 #cache stringT #timestamp ("/test-" <> nominalDiffTimeSecondsT <> ".db")
                cache <- getXdgDirectory XdgCache "sqlitefs"
                createDirectoryIfMissing True cache
                timestamp <- Posix.getPOSIXTime
                pure $ buildText tmpl $ t2 #cache cache #timestamp timestamp
              putStderrLn $ "Test failed, dumping database to " <> tmpFile
              Sqlite.executeNamed (sqlite.connection) "VACUUM INTO :path" [":path" := tmpFile]
            False -> pure ()
      )
      ( Test.aroundWith
          (\act sqlite -> Sqlite.withTransaction (sqlite.connection) (act sqlite))
          spec
      )

createTestTable :: Connection -> IO ()
createTestTable conn = do
  Sqlite.executeNamed
    conn
    [sql|
    CREATE TABLE IF NOT EXISTS files (
      filename TEXT PRIMARY KEY,
      filecontent BLOB
    )
  |]
    []

-- So I want to create a tree of files, and then the property to check should be that
-- the file content is the same as the file content of the file in the tree.
-- listing a directory should return the children of the directory in the tree object, and they should be directories if they have children themselves, and files otherwise.

test_list_directory :: Test.Spec
test_list_directory = describe "test_list_directory" $ withMemorySqlite createTestTable $ do
  it "lists a directory" $ \sqlite -> do
    hedgehog $ do
      files <- Hedge.forAll $ genTree (t2 #depth (Range.linear 0 2) #width (Range.linear 1 2)) (Gen.text (Range.linear 1 2) (Gen.element ['a' .. 'c']))
      -- insert all files
      for_ files $ \file -> do
        liftIO $
          Sqlite.executeNamed
            (sqlite.connection)
            [sql|
            INSERT INTO files (filename, filecontent)
            VALUES (:filename, :filecontent) ON CONFLICT(filename)
            DO UPDATE SET filecontent = :filecontent
          |]
            [":filename" := file, ":filecontent" := B.empty]
      -- list the directory via fuseReadDirectory
      (liftIO $ myFuseReadDirectory (sqlite.connection) "/") >>= \case
        Left e -> sqlite & hedgeFailure [fmt|error: {displayException $ errnoToIOError "" e Nothing Nothing}|]
        Right rows -> do
          Hedge.annotateShow rows
          Hedge.assert $ length rows == length files

hedgeFailure :: (HasCallStack) => Text -> Sqlite -> Hedge.PropertyT IO ()
hedgeFailure msg sqlite = do
  liftIO $ writeIORef (sqlite.hasFailed) True
  Hedge.annotate (textToString msg)
  Hedge.failure

test_directory_traversal :: Test.Spec  
test_directory_traversal = describe "test_directory_traversal" $ do
  describe "root directory listing" $ withMemorySqlite createTestTable $ do
    it "lists root directory correctly" $ \sqlite -> do
      -- Insert test files: topfile (root level), a/b and a/c (directory a)
      Sqlite.executeNamed (sqlite.connection) "INSERT INTO files (filename, filecontent) VALUES (:filename, :filecontent)" [(":filename" := ("topfile" :: String)), (":filecontent" := ("top level content" :: ByteString))]
      Sqlite.executeNamed (sqlite.connection) "INSERT INTO files (filename, filecontent) VALUES (:filename, :filecontent)" [(":filename" := ("a/b" :: String)), (":filecontent" := ("test content" :: ByteString))]
      Sqlite.executeNamed (sqlite.connection) "INSERT INTO files (filename, filecontent) VALUES (:filename, :filecontent)" [(":filename" := ("a/c" :: String)), (":filecontent" := ("more content" :: ByteString))]
      
      -- Test root directory listing
      myFuseReadDirectory (sqlite.connection) "/" >>= \case
        Left _e -> testErr "Root directory listing failed"
        Right rows -> do
          let filenames = map fst rows
          filenames `shouldBe` ["a/b", "a/c", "topfile"]  -- Should show all files in root and at one level deep
          
  describe "subdirectory listing" $ withMemorySqlite createTestTable $ do
    it "lists subdirectory correctly" $ \sqlite -> do
      -- Insert test files in subdirectory structure
      Sqlite.executeNamed (sqlite.connection) "INSERT INTO files (filename, filecontent) VALUES (:filename, :filecontent)" [(":filename" := ("a/file1" :: String)), (":filecontent" := ("content1" :: ByteString))]
      Sqlite.executeNamed (sqlite.connection) "INSERT INTO files (filename, filecontent) VALUES (:filename, :filecontent)" [(":filename" := ("a/file2" :: String)), (":filecontent" := ("content2" :: ByteString))]
      Sqlite.executeNamed (sqlite.connection) "INSERT INTO files (filename, filecontent) VALUES (:filename, :filecontent)" [(":filename" := ("a/sub/file3" :: String)), (":filecontent" := ("content3" :: ByteString))]
      
      -- Test subdirectory listing
      myFuseReadDirectory (sqlite.connection) "/a" >>= \case
        Left _e -> testErr "Subdirectory listing failed"
        Right rows -> do
          let filenames = map fst rows
          filenames `shouldBe` ["a/file1", "a/file2"]  -- Should only show direct children, not a/sub/file3

-- test_create_and_read_file :: Test.Spec
-- test_create_and_read_file = describe "test_create_and_read_file" $ withMemorySqlite createTestTable $ do
--   it "creates and reads a file" $ \conn -> do
--     hedgehog $ do
--       files <- Hedge.forAll $ genTree (t2 #depth (Range.linear 0 2) #width (Range.linear 1 2)) (Gen.text (Range.linear 1 2) (Gen.element ['a' .. 'c']))
--       dat <- Hedge.forAll $ do
--         filename <-
--           genTree (t2 #depth (Range.linear 0 2) #width (Range.linear 1 2)) (Gen.text (Range.linear 1 2) (Gen.element ['a' .. 'c']))
--             <&> treeToPathList
--             <&> Text.intercalate "/"
--         filecontents <- Gen.text (Range.exponential 0 100) Gen.alphaNum
--         pure $ t2 #filename filename #filecontents filecontents
--       liftIO $ do
--         Sqlite.executeNamed
--           conn
--           [sql|
--             INSERT INTO files (filename, filecontent)
--             VALUES (:filename, :filecontents) ON CONFLICT(filename)
--             DO UPDATE SET filecontent = :filecontents
--           |]
--           [":filename" := dat.filename, ":filecontents" := textToBytesUtf8 dat.filecontents]
--       rows <-
--         liftIO $
--           queryNamedWith
--             conn
--             [sql|
--               SELECT filecontent FROM files WHERE filename = :filename
--             |]
--             [":filename" := dat.filename]
--             (columnIdx 0 "filecontent" <&> sqlDataToText)
--       case rows of
--         [content] -> Hedge.assert $ content == dat.filecontents
--         _ -> do
--           Hedge.annotate "Expected exactly one row"
--           Hedge.failure

genTree :: forall a. T2 "depth" (Range Int) "width" (Range Int) -> Gen a -> Gen (Tree a)
genTree dat genVal = do
  depth <- Gen.int dat.depth
  go depth
  where
    go :: Int -> Gen (Tree a)
    go 0 = genVal <&> \v -> Tree.Node v []
    go d = do
      v <- genVal
      children <- Gen.list dat.width (go (d - 1))
      pure $ Tree.Node v children

tryGenTree :: IO ()
tryGenTree = runTest $ it "tryGenTree" $ hedgehog $ do
  tree <- Hedge.forAll $ genTree (t2 #depth (Range.linear 0 2) #width (Range.linear 1 2)) (Gen.text (Range.linear 1 4) (Gen.element ['a' .. 'c']))
  liftIO $ print $ treeToPathList tree & map (Text.intercalate "/")
  pure ()

-- Create the full path for every element in the tree
treeToPathList :: Tree a -> [[a]]
treeToPathList (Tree.Node value children) =
  [value] : concatMap (map (value :)) (treeToPathList <$> children)

foo :: IO ()
foo = (Gen.print $ genTree (t2 #depth (Range.linear 1 2) #width (Range.linear 1 2)) (Gen.text (Range.linear 1 4) (Gen.element ['a' .. 'c'])))