SQLiteDAV (empty) → 0.2.0.0
raw patch · 12 files changed
+5240/−0 lines, 12 filesdep +SQLiteDAVdep +aesondep +basesetup-changed
Dependencies added: SQLiteDAV, aeson, base, bytestring, containers, directory, exceptions, filepath, hspec, hspec-wai, http-types, magic, mime-types, optparse-applicative, protolude, regex-tdfa, servant, servant-foreign, servant-options, servant-server, sqlite-simple, text, time, unix, wai, wai-extra, warp, xml, xml-conduit, zlib
Files
- README.md +86/−0
- SQLiteDAV.cabal +165/−0
- Setup.hs +4/−0
- app/Main.hs +97/−0
- src/SQLiteDAV/API.hs +124/−0
- src/SQLiteDAV/HTTPExtensions.hs +174/−0
- src/SQLiteDAV/MimeDetect.hs +62/−0
- src/SQLiteDAV/Properties.hs +226/−0
- src/SQLiteDAV/SQLAR.hs +489/−0
- src/SQLiteDAV/Server.hs +2082/−0
- src/SQLiteDAV/Utils.hs +35/−0
- test/Spec.hs +1696/−0
+ README.md view
@@ -0,0 +1,86 @@+# SQLiteDAV++WebDAV server that maps an SQLite database to directories/files.++| | |+---|---+Database Schema | +File View | +++## Installation++### From Binaries++1. Go to https://github.com/Airsequel/SQLiteDAV/releases+1. Download the latest release for your platform+1. Unzip the archive:+ ```sh+ unzip sqlitedav_*.zip+ ```+1. Make the binary executable:+ ```sh+ chmod +x sqlitedav+ ```+++### From Source++Prerequisite:+[Install Stack](https://docs.haskellstack.org/en/stable/#how-to-install-stack)++```sh+git clone https://github.com/Airsequel/SQLiteDAV+cd SQLiteDAV+stack install+```+++## Usage++1. Start WebDAV server:+ ```sh+ sqlitedav path/to/database.sqlite+ ```+2. Connect your WebDAV client to `http://localhost:1234` \+ (E.g. with macOS Finder by executing `cmd + k`)+++## WebDAV Compliance++The repository ships a Dockerised setup for running the [Litmus]+protocol compliance test suite against a local SQLiteDAV instance.+It points Litmus at an empty sqlar archive so the test files it+creates do not collide with the committed fixtures.++```sh+make litmus+```++The target builds a small container image (Debian + `litmus`),+starts SQLiteDAV against a scratch database, and runs Litmus+against `http://host.docker.internal:1234/sqlar/`. Set+`LITMUS_PORT` to use a different port.+++## Roadmap++The next features are implemented based on popular demand.+So please upvote any [issues](https://github.com/Airsequel/SQLiteDAV/issues)+you would like to see implemented!+++## Related++- [Litmus] - WebDAV server protocol compliance test suite.+- [Many Hells of WebDAV] - Article about the discrepancies in WebDAV implementations.+- [sqlite-fs] - Mount a SQLite database as a normal filesystem on Linux and macOS.+- [sqlite.org/cloudsqlite][cloudsqlite] - Cloud backed SQLite system.+- [wddbfs] - [webdavfs] provider that can read sqlite databases.++[cloudsqlite]: https://sqlite.org/cloudsqlite/doc/trunk/www/index.wiki+[Litmus]: https://github.com/notroj/litmus+[Many Hells of WebDAV]: https://candid.dev/blog/many-hells-of-webdav+[sqlite-fs]: https://github.com/narumatt/sqlitefs+[wddbfs]: https://github.com/adamobeng/wddbfs+[webdavfs]: https://github.com/miquels/webdavfs
+ SQLiteDAV.cabal view
@@ -0,0 +1,165 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name: SQLiteDAV+version: 0.2.0.0+synopsis: WebDAV server that maps an SQLite database to directories and files.+description: SQLiteDAV is a WebDAV server that exposes an SQLite database as a+ filesystem-like hierarchy.+ .+ It supports two modes:+ .+ * Plain SQLite databases, where tables become folders, rows become+ folders keyed by rowid, and columns become files named+ @\<col\>.\<ext\>@ with the extension derived from the cell's type.+ .+ * SQLite Archive (sqlar) databases, where paths inside the archive+ table are exposed as a filesystem.+ .+ This lets you mount an SQLite database via any WebDAV client (Finder,+ GNOME Files, Windows Explorer, davfs2, etc.) and browse, read, and+ edit its contents as regular files and folders.+category: Web, Database+homepage: https://github.com/Airsequel/SQLiteDAV#readme+bug-reports: https://github.com/Airsequel/SQLiteDAV/issues+author: Adrian Sieber+maintainer: Adrian Sieber+license: MIT+build-type: Simple+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/Airsequel/SQLiteDAV++library+ exposed-modules:+ SQLiteDAV.API+ SQLiteDAV.HTTPExtensions+ SQLiteDAV.MimeDetect+ SQLiteDAV.Properties+ SQLiteDAV.Server+ SQLiteDAV.SQLAR+ SQLiteDAV.Utils+ other-modules:+ Paths_SQLiteDAV+ hs-source-dirs:+ src+ default-extensions:+ NoImplicitPrelude+ OverloadedRecordDot+ OverloadedStrings+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , directory+ , exceptions+ , filepath+ , http-types+ , magic+ , mime-types+ , protolude+ , regex-tdfa+ , servant+ , servant-foreign+ , servant-options+ , servant-server+ , sqlite-simple+ , text+ , time+ , unix+ , wai-extra+ , xml+ , xml-conduit+ , zlib+ default-language: GHC2021++executable sqlitedav+ main-is: Main.hs+ other-modules:+ Paths_SQLiteDAV+ hs-source-dirs:+ app+ default-extensions:+ NoImplicitPrelude+ OverloadedRecordDot+ OverloadedStrings+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ SQLiteDAV+ , aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , directory+ , exceptions+ , filepath+ , http-types+ , magic+ , mime-types+ , optparse-applicative+ , protolude+ , regex-tdfa+ , servant+ , servant-foreign+ , servant-options+ , servant-server+ , sqlite-simple+ , text+ , time+ , unix+ , wai-extra+ , warp+ , xml+ , xml-conduit+ , zlib+ default-language: GHC2021++test-suite sqlitedav-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_SQLiteDAV+ hs-source-dirs:+ test+ default-extensions:+ NoImplicitPrelude+ OverloadedRecordDot+ OverloadedStrings+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -main-is Spec+ build-depends:+ SQLiteDAV+ , aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , directory+ , exceptions+ , filepath+ , hspec+ , hspec-wai+ , http-types+ , magic+ , mime-types+ , protolude+ , regex-tdfa+ , servant+ , servant-foreign+ , servant-options+ , servant-server+ , sqlite-simple+ , text+ , time+ , unix+ , wai+ , wai-extra+ , xml+ , xml-conduit+ , zlib+ default-language: GHC2021
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Main where++import Protolude (+ IO,+ Int,+ Maybe (..),+ Text,+ die,+ fromMaybe,+ pure,+ putText,+ show,+ ($),+ (&),+ (<$>),+ (<*>),+ (<>),+ )++import Data.Text qualified as T+import Network.Wai.Handler.Warp (run)+import Network.Wai.Middleware.RequestLogger (logStdoutDev)+import Options.Applicative (+ Parser,+ argument,+ auto,+ execParser,+ fullDesc,+ help,+ helper,+ info,+ long,+ metavar,+ option,+ optional,+ progDesc,+ str,+ strOption,+ (<**>),+ )++import SQLiteDAV.Server (RowNameMode (..), parseRowNameMode, webDavServer)+++data Options = Options+ { port :: Maybe Int+ , rowName :: Maybe Text+ , dbPath :: Text+ }+++optionsParser :: Parser Options+optionsParser =+ Options+ <$> optional+ ( option+ auto+ ( long "port"+ <> metavar "INT"+ <> help "Port to listen on (default: 1234)"+ )+ )+ <*> optional+ ( strOption+ ( long "rowname"+ <> metavar "TEXT"+ <> help+ "How to name row directories: \+ \rowid (default), pk, or combined"+ )+ )+ <*> argument str (metavar "DB_PATH" <> help "Path to SQLite database file")+++main :: IO ()+main = do+ options <-+ execParser $+ info+ (optionsParser <**> helper)+ (fullDesc <> progDesc "SQLiteDAV server")+ let thePort = options.port & fromMaybe 1234+ rowMode <- case options.rowName of+ Nothing -> pure RowIdMode+ Just raw -> case parseRowNameMode raw of+ Just m -> pure m+ Nothing ->+ die $+ "Invalid --rowname value: "+ <> raw+ <> " (expected rowid, pk, or combined)"+ putText $ "Starting server on http://localhost:" <> show thePort+ run thePort $+ logStdoutDev $+ webDavServer rowMode (T.unpack options.dbPath)
+ src/SQLiteDAV/API.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}++module SQLiteDAV.API where++import Protolude (Char, Integer, Maybe (..), Show, (<>))++import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BL+import Data.Text (Text)+import Database.SQLite.Simple (SQLData)+import Servant (+ CaptureAll,+ Get,+ Header,+ Headers,+ JSON,+ NoContent,+ OctetStream,+ PlainText,+ Proxy (..),+ ReqBody,+ StdMethod (DELETE, OPTIONS, PUT),+ Verb,+ type (:<|>),+ type (:>),+ )+import Servant.API.ContentTypes (AllCTRender, AllMime, handleAcceptH)+import Text.XML.Light (Element)++import SQLiteDAV.HTTPExtensions (+ AppXML,+ Copy,+ Lock,+ Mkcol,+ Move,+ Propfind,+ TextXML,+ Unlock,+ )+import SQLiteDAV.Properties (LockResult, PropResults)+import SQLiteDAV.Utils (sqlDataToFileContent)+++type String = [Char]+++type Options = Verb 'OPTIONS 200+++type Delete = Verb 'DELETE 204+++data WithContentType = WithContentType+ { header :: BL.ByteString+ , content :: SQLData+ }+ deriving (Show)+++instance AllCTRender '[OctetStream] WithContentType where+ handleAcceptH _ _ (WithContentType header content) =+ Just (header, sqlDataToFileContent content)+++instance AllCTRender '[] NoContent where+ handleAcceptH _ _ _ = Nothing+++-- `PlainText` content types appear throughout to avoid 406 Not+-- Acceptable for clients that send an Accept header.+type WebDavAPI =+ CaptureAll "segments" String+ -- MKCOL: RFC 4918 §9.3 — body must be empty, hence the Content-Length+ -- header guard in the handler.+ :> Header "Content-Length" Integer+ :> Mkcol '[PlainText] NoContent+ :<|> CaptureAll "segments" String+ :> Header "Depth" Text+ :> Header "Prefer" Text+ -- OctetStream covers requests that arrive without a Content-Type+ -- header (servant's default media type). The body is still+ -- validated as XML by the MimeUnrender instance.+ :> ReqBody '[AppXML, TextXML, OctetStream] Element+ :> Propfind+ '[AppXML, TextXML]+ (Headers '[Header "Preference-Applied" String] [PropResults])+ :<|> CaptureAll "segments" String+ :> Get '[OctetStream] WithContentType+ :<|> CaptureAll "segments" String+ :> ReqBody '[OctetStream] ByteString+ -- PUT returns 201 Created on success (RFC 4918 §9.7).+ :> Verb 'PUT 201 '[PlainText] NoContent+ :<|> CaptureAll "segments" String+ :> Delete '[PlainText] NoContent+ :<|> CaptureAll "segments" String+ :> Header "Destination" String+ :> Header "Overwrite" String+ :> Move '[PlainText] NoContent+ :<|> CaptureAll "segments" String+ :> Header "Destination" String+ :> Header "Overwrite" String+ :> Header "Depth" String+ :> Copy '[PlainText] NoContent+ :<|> CaptureAll "segments" String+ :> Lock+ '[AppXML, TextXML]+ (Headers '[Header "Lock-Token" String] LockResult)+ :<|> CaptureAll "segments" String+ :> Header "Lock-Token" String+ :> Unlock '[PlainText] NoContent+ :<|> CaptureAll "segments" String+ :> Options '[PlainText] NoContent+++-- :<|> Proppatch '[JSON] [Int]+-- :<|> Orderpatch '[JSON] [Int]+-- :<|> Post '[JSON] [Int]++-- :<|> Head '[JSON] [Int]+-- :<|> Trace '[JSON] [Int]++webDavAPI :: Proxy WebDavAPI+webDavAPI = Proxy
+ src/SQLiteDAV/HTTPExtensions.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module SQLiteDAV.HTTPExtensions where++import Protolude (+ Bool (..),+ Char,+ Either (..),+ Maybe (..),+ any,+ not,+ otherwise,+ show,+ ($),+ (&&),+ (++),+ (.),+ (==),+ (||),+ )++import Control.Exception (SomeException)+import Data.ByteString.Lazy qualified as BL+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy.Encoding qualified as TL+import Servant (+ Accept (contentType),+ MimeUnrender (mimeUnrender),+ OctetStream,+ ReflectMethod (..),+ Verb,+ )+import Servant.Foreign.Internal ()+import Text.XML qualified as XC+import Text.XML.Light (Element, parseXMLDoc)+++data DavMethod+ = MKCOL+ | PROPFIND+ | PROPPATCH+ | LOCK+ | UNLOCK+ | ORDERPATCH+ | COPY+ | MOVE+++-- OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, COPY, MOVE+-- are already defined by Servant++instance ReflectMethod 'MKCOL where+ reflectMethod _ = "MKCOL"+instance ReflectMethod 'PROPFIND where+ reflectMethod _ = "PROPFIND"+instance ReflectMethod 'PROPPATCH where+ reflectMethod _ = "PROPPATCH"+instance ReflectMethod 'LOCK where+ reflectMethod _ = "LOCK"+instance ReflectMethod 'UNLOCK where+ reflectMethod _ = "UNLOCK"+instance ReflectMethod 'ORDERPATCH where+ reflectMethod _ = "ORDERPATCH"+++-- instance ReflectMethod 'HEAD where+-- reflectMethod _ = "HEAD"+-- instance ReflectMethod 'TRACE where+-- reflectMethod _ = "TRACE"+instance ReflectMethod 'COPY where+ reflectMethod _ = "COPY"+instance ReflectMethod 'MOVE where+ reflectMethod _ = "MOVE"+++-- MKCOL returns 201 Created on success per RFC 4918 §9.3.1.+type Mkcol = Verb 'MKCOL 201+type Propfind = Verb 'PROPFIND 207+type Proppatch = Verb 'PROPPATCH 200+type Lock = Verb 'LOCK 200+type Unlock = Verb 'UNLOCK 204+type Orderpatch = Verb 'ORDERPATCH 200+++-- type Head = Verb 'HEAD 200+-- type Trace = Verb 'TRACE 200+-- COPY/MOVE return 201 Created when the destination is new (RFC 4918+-- §9.8.5/§9.9.4). Handlers return 204 No Content for overwrites by+-- throwing a tailored ServerError.+type Copy = Verb 'COPY 201+type Move = Verb 'MOVE 201+++data AppXML = AppXML+++{-| Reject prefixed names bound to an empty namespace URI.++xml-conduit follows Namespaces 1.1's lenient "undeclaration" rule+and quietly produces @nameNamespace = Just ""@ rather than+rejecting the declaration. Per Namespaces 1.0 (which most WebDAV+clients still expect) the binding is invalid, so we walk the+parsed document and refuse it explicitly.+-}+hasEmptyPrefixedNamespace :: XC.Document -> Bool+hasEmptyPrefixedNamespace = checkElement . XC.documentRoot+ where+ checkElement el =+ isBadName (XC.elementName el)+ || any isBadName (Map.keys (XC.elementAttributes el))+ || any checkNode (XC.elementNodes el)+ checkNode (XC.NodeElement el) = checkElement el+ checkNode _ = False+ isBadName n =+ case XC.namePrefix n of+ Just prefix+ | not (T.null prefix) ->+ XC.nameNamespace n == Just T.empty+ _ -> False+++{-| Parse the request body as XML.++xml-light is too permissive (it accepts unclosed tags like @<foo>@+as if they were self-closing and ignores invalid namespace+declarations). xml-conduit does proper XML 1.0 parsing, so we use+it as a well-formedness gate. We additionally reject prefixed+names bound to the empty namespace URI to catch the @xmlns:p=""@+case that xml-conduit treats as a prefix undeclaration. Only+bodies that pass both checks are fed to xml-light for the+'Element' representation the handler already consumes.+-}+xmlMimeUnrender :: BL.ByteString -> Either [Char] Element+xmlMimeUnrender bytes =+ case XC.parseLBS XC.def bytes :: Either SomeException XC.Document of+ Left e -> Left $ "Malformed XML: " ++ show e+ Right doc+ | hasEmptyPrefixedNamespace doc ->+ Left "Prefixed name bound to empty namespace URI"+ | otherwise ->+ case parseXMLDoc (TL.decodeUtf8 bytes) of+ Nothing -> Left $ "Could not represent XML as Element"+ Just el -> Right el+++instance MimeUnrender AppXML Element where+ mimeUnrender _ = xmlMimeUnrender+++instance Accept AppXML where+ contentType _ = "application/xml"+++-- Used by macOS's Finder+data TextXML = TextXML+++instance MimeUnrender TextXML Element where+ mimeUnrender _ = xmlMimeUnrender+++instance Accept TextXML where+ contentType _ = "text/xml"+++-- Some clients (notably neon, used by litmus) send a PROPFIND body+-- without a Content-Type header at all. Servant then defaults to+-- @application/octet-stream@; route those bodies through the same+-- XML well-formedness check instead of rejecting with 415.+instance MimeUnrender OctetStream Element where+ mimeUnrender _ = xmlMimeUnrender
+ src/SQLiteDAV/MimeDetect.hs view
@@ -0,0 +1,62 @@+module SQLiteDAV.MimeDetect (detectMimeType, extensionForMime) where++import Protolude (+ IO,+ Maybe (..),+ otherwise,+ pure,+ ($),+ (.),+ (/=),+ )++import Control.Concurrent.MVar (MVar, newMVar, withMVar)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BSC+import Data.ByteString.Unsafe qualified as BSU+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Magic (Magic)+import Magic.Data (MagicFlag (MagicMimeType))+import Magic.Init (magicLoadDefault, magicOpen)+import Magic.Operations (magicCString)+import Network.Mime (defaultExtensionMap)+import System.IO.Unsafe (unsafePerformIO)+++-- libmagic handles are not thread-safe, so a single shared handle is+-- serialized through an MVar. Loading the magic database is expensive,+-- so we cache the handle for the lifetime of the process.+{-# NOINLINE globalMagic #-}+globalMagic :: MVar Magic+globalMagic = unsafePerformIO $ do+ magic <- magicOpen [MagicMimeType]+ magicLoadDefault magic+ newMVar magic+++{-| Identify the MIME type of a byte buffer using libmagic.+Returns "application/octet-stream" for empty input.+-}+detectMimeType :: ByteString -> IO Text+detectMimeType bs+ | BS.null bs = pure "application/octet-stream"+ | otherwise =+ withMVar globalMagic $ \magic -> do+ result <- BSU.unsafeUseAsCStringLen bs (magicCString magic)+ pure $ T.pack result+++{-| Canonical file extension for a MIME type, e.g.+"image/png" -> Just "png". Returns Nothing if unknown.+-}+extensionForMime :: Text -> Maybe Text+extensionForMime mime =+ let+ bare = BSC.takeWhile (/= ';') (BSC.pack $ T.unpack mime)+ in+ case Map.lookup bare defaultExtensionMap of+ Just (ext : _) -> Just ext+ _ -> Nothing
+ src/SQLiteDAV/Properties.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# HLINT ignore "Use list comprehension" #-}++module SQLiteDAV.Properties where++import Protolude (+ Char,+ Eq,+ FilePath,+ IO,+ Maybe (..),+ Show,+ Text,+ fmap,+ not,+ null,+ pure,+ putStrLn,+ show,+ ($),+ (++),+ (.),+ (<&>),+ )++import Data.Aeson (FromJSON (parseJSON), ToJSON, toJSON)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy.Char8 qualified as Lazy.Char8+import Data.Either (lefts, rights)+import Data.Text qualified as T+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Traversable (for)+import Database.SQLite.Simple (SQLData)+import GHC.Generics (Generic)+import Protolude.Error (error)+import Servant (MimeRender (..), MimeUnrender (..), OctetStream, PlainText)+import System.Directory (+ doesDirectoryExist,+ doesFileExist,+ getModificationTime,+ )+import System.FilePath.Posix (takeExtension, takeFileName)+import System.Posix (fileSize, getFileStatus)+import Text.XML.Light (+ Attr (Attr),+ CData (CData),+ CDataKind (CDataText),+ Content (Elem, Text),+ Element (Element, elAttribs, elContent, elLine, elName),+ QName (QName, qName, qPrefix, qURI),+ showTopElement,+ unqual,+ )++import SQLiteDAV.HTTPExtensions (AppXML, TextXML)+import SQLiteDAV.Utils (sqlDataToFileContent)+++type String = [Char]+++instance FromJSON ByteString where+ parseJSON = error "FromJSON ByteString not implemented"+++instance FromJSON Element where+ parseJSON = error "FromJSON Element not implemented"+++data ItemType = File | Folder+ deriving (Show, Eq, Generic)+++instance ToJSON ItemType+++data PropResults = PropResults+ { propName :: String+ , itemType :: ItemType+ , props :: [(String, String)]+ , propMissing :: [String]+ }+ deriving (Show, Generic)+++instance ToJSON PropResults+++data LockResult = LockResult+ { lockToken :: String+ , lockRoot :: String+ }+ deriving (Show, Generic)+++instance ToJSON LockResult+++e :: String -> [Attr] -> [Element] -> Element+e name attrs content =+ Element+ { elName =+ QName+ { qName = name+ , qURI = Nothing+ , qPrefix = Just "D"+ }+ , elAttribs = attrs+ , elContent = content <&> Elem+ , elLine = Nothing+ }+++te :: String -> [Attr] -> String -> Element+te name attrs text =+ Element+ { elName = QName{qName = name, qURI = Nothing, qPrefix = Just "D"}+ , elAttribs = attrs+ , elContent = [Text $ CData CDataText text Nothing]+ , elLine = Nothing+ }+++xmlMimeRender :: [PropResults] -> Lazy.Char8.ByteString+xmlMimeRender items =+ Lazy.Char8.pack+ $ showTopElement+ $ e+ "multistatus"+ [Attr (unqual "xmlns:D") "DAV:"]+ $ items+ <&> propResultsToXml+++instance MimeRender AppXML [PropResults] where+ mimeRender _ = xmlMimeRender+++instance MimeRender TextXML [PropResults] where+ mimeRender _ = xmlMimeRender+++lockResultToXml :: LockResult -> Element+lockResultToXml LockResult{..} =+ e+ "prop"+ [Attr (unqual "xmlns:D") "DAV:"]+ [ e+ "lockdiscovery"+ []+ [ e+ "activelock"+ []+ [ e "locktype" [] [e "write" [] []]+ , e "lockscope" [] [e "exclusive" [] []]+ , te "depth" [] "infinity"+ , te "timeout" [] "Second-604800"+ , e "locktoken" [] [te "href" [] lockToken]+ , e "lockroot" [] [te "href" [] lockRoot]+ ]+ ]+ ]+++xmlMimeRenderLock :: LockResult -> Lazy.Char8.ByteString+xmlMimeRenderLock = Lazy.Char8.pack . showTopElement . lockResultToXml+++instance MimeRender AppXML LockResult where+ mimeRender _ = xmlMimeRenderLock+++instance MimeRender TextXML LockResult where+ mimeRender _ = xmlMimeRenderLock+++instance MimeRender PlainText SQLData where+ mimeRender _ = sqlDataToFileContent+++instance MimeRender OctetStream SQLData where+ mimeRender _ = sqlDataToFileContent+++propResultsToXml :: PropResults -> Element+propResultsToXml PropResults{..} = do+ e+ "response"+ []+ ( [ te "href" [] $ "/" ++ propName+ , e+ "propstat"+ []+ [ te "status" [] "HTTP/1.1 200 OK"+ , e+ "prop"+ []+ ( ( case itemType of+ File -> []+ Folder ->+ [e "resourcetype" [] [e "collection" [] []]]+ )+ ++ fmap (\(name, val) -> te name [] val) props+ )+ ]+ ]+ ++ ( if not (null propMissing)+ then+ [ e+ "propstat"+ []+ [ te "status" [] "HTTP/1.1 404 Not Found"+ , e "prop" [] $ fmap (\x -> e x [] []) propMissing+ , te "responsedescription" [] "Property was not found"+ ]+ ]+ else []+ )+ )
+ src/SQLiteDAV/SQLAR.hs view
@@ -0,0 +1,489 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}++{-| Support for SQLite Archive Files (sqlar).++A table is treated as a sqlar archive when its schema matches+the standard sqlar specification:++@+CREATE TABLE sqlar(+ name TEXT PRIMARY KEY,+ mode INT,+ mtime INT,+ sz INT,+ data BLOB+);+@++See <https://www.sqlite.org/sqlar.html>.+-}+module SQLiteDAV.SQLAR (+ SqlarEntry (..),+ SqlarFile (..),+ isSqlarTable,+ listAt,+ lookupEntry,+ hasPath,+ parentPath,+ parentExists,+ resolvePath,+ decompressData,+ insertEntry,+ deleteEntry,+ deleteSubtree,+ copySubtree,+ archivePath,+ rootEntry,+) where++import Protolude (+ Bool (..),+ Char,+ Eq,+ FilePath,+ IO,+ Int,+ Integer,+ Maybe (..),+ Show,+ Text,+ fmap,+ for_,+ fromIntegral,+ not,+ otherwise,+ pure,+ ($),+ (&&),+ (.),+ (<),+ (<=),+ (<>),+ (==),+ (>),+ (||),+ )++import Data.Bits ((.&.))+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.Function ((&))+import Data.List qualified as List+import Data.Maybe (catMaybes)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Database.SQLite.Simple (+ Only (..),+ Query (Query),+ SQLData (..),+ execute,+ query,+ query_,+ withConnection,+ )++import Codec.Compression.Zlib qualified as Zlib++import SQLiteDAV.Properties (ItemType (File, Folder))+++-- | A listing entry directly under some archive path.+data SqlarEntry = SqlarEntry+ { entryName :: Text+ -- ^ Path relative to the listing prefix (e.g. "foo.txt" or "subdir").+ , entryFullName :: Text+ -- ^ Full path inside the archive (without leading slash).+ , entryType :: ItemType+ , entrySize :: Integer+ -- ^ Reported file size (column @sz@). Zero for folders.+ , entryMtime :: Maybe UTCTime+ }+ deriving (Show, Eq)+++-- | A resolved file entry from the archive.+data SqlarFile = SqlarFile+ { fileContent :: ByteString+ , fileMtime :: Maybe UTCTime+ , fileSize :: Integer+ }+ deriving (Show)+++sqlarColumns :: [Text]+sqlarColumns = ["name", "mode", "mtime", "sz", "data"]+++{-| True if @tableName@ has the sqlar schema (the columns+@name@, @mode@, @mtime@, @sz@, @data@).+-}+isSqlarTable :: FilePath -> Text -> IO Bool+isSqlarTable dbPath tableName =+ withConnection dbPath $ \conn -> do+ cols :: [Only Text] <-+ query+ conn+ "SELECT name FROM pragma_table_info(?)"+ (Only tableName)+ let names = fmap (\(Only n) -> n) cols+ pure $ List.all (`List.elem` names) sqlarColumns+++{-| Normalize the listing prefix so it always ends with a slash+(unless empty, which means "root of archive").+-}+normalizePrefix :: Text -> Text+normalizePrefix p+ | T.null p = ""+ | T.isSuffixOf "/" p = p+ | otherwise = p <> "/"+++-- | Build the archive-internal path from URL path segments.+archivePath :: [[Char]] -> Text+archivePath segments =+ segments+ & List.filter (not . List.null)+ & fmap T.pack+ & T.intercalate "/"+++{-| List entries directly under @prefix@ (which must end with @/@+or be empty for the archive root).++Only the metadata columns are projected — the @data@ BLOB is replaced+with a cheap @data IS NULL@ probe so listing a multi-gigabyte archive+does not pull every payload into memory (see GitHub issue #14).+-}+listAt :: FilePath -> Text -> Text -> IO [SqlarEntry]+listAt dbPath tableName rawPrefix = do+ let prefix = normalizePrefix rawPrefix+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "SELECT name, mode, mtime, sz, data IS NULL FROM "+ <> quoteIdent tableName+ rows :: [(Text, SQLData, SQLData, SQLData, Bool)] <- query_ conn q+ pure $ dedupe (catMaybes (fmap (rowToEntry prefix) rows))+++rowToEntry ::+ Text ->+ (Text, SQLData, SQLData, SQLData, Bool) ->+ Maybe SqlarEntry+rowToEntry prefix (name, modeData, mtimeData, szData, dataIsNull) =+ let+ canonName =+ if T.isSuffixOf "/" name && T.length name > 1+ then T.dropEnd 1 name+ else name++ inScope =+ T.null prefix+ || T.isPrefixOf prefix canonName+ || T.isPrefixOf prefix (canonName <> "/")++ relative =+ if T.null prefix+ then canonName+ else T.drop (T.length prefix) canonName++ isSelf = T.null relative++ (segment, rest) = T.break (== '/') relative++ isExplicitFolder =+ T.isSuffixOf "/" name+ || isDirMode modeData+ || (dataIsNull && szIsZero szData)++ childType =+ if T.null rest && not isExplicitFolder+ then File+ else Folder++ fullName =+ if T.null prefix+ then segment+ else prefix <> segment++ sz = case childType of+ File -> sqlInt szData+ Folder -> 0+ in+ if not inScope || isSelf || T.null segment+ then Nothing+ else+ Just+ SqlarEntry+ { entryName = segment+ , entryFullName = fullName+ , entryType = childType+ , entrySize = sz+ , entryMtime = sqlMtime mtimeData+ }+++{-| Collapse duplicates produced by multiple rows that share the+same first segment. Folder type wins when both appear.+-}+dedupe :: [SqlarEntry] -> [SqlarEntry]+dedupe entries =+ let+ sorted = List.sortOn entryName entries+ byName = List.groupBy (\a b -> a.entryName == b.entryName) sorted+ in+ fmap mergeGroup byName+ where+ -- `groupBy` always produces non-empty groups, so the fallback+ -- pattern match below is exhaustive.+ mergeGroup grp =+ let+ folder = List.find (\e -> e.entryType == Folder) grp+ in+ case folder of+ Just f -> f+ Nothing -> case grp of+ (x : _) -> x+ [] -> rootEntry+++-- | Look up a single file entry by exact archive path.+lookupEntry :: FilePath -> Text -> Text -> IO (Maybe SqlarFile)+lookupEntry dbPath tableName path =+ withConnection dbPath $ \conn -> do+ let canon =+ if T.isSuffixOf "/" path && T.length path > 1+ then T.dropEnd 1 path+ else path+ q =+ Query $+ "SELECT sz, mtime, data FROM "+ <> quoteIdent tableName+ <> " WHERE name = ? OR name = ?"+ rows :: [(SQLData, SQLData, SQLData)] <-+ query conn q (canon, canon <> "/")+ pure $ case rows of+ [] -> Nothing+ ((szData, mtimeData, dataCol) : _) ->+ let+ sz = sqlInt szData+ in+ Just+ SqlarFile+ { fileContent = decompressData dataCol sz+ , fileMtime = sqlMtime mtimeData+ , fileSize = sz+ }+++-- | Virtual entry representing the archive root.+rootEntry :: SqlarEntry+rootEntry =+ SqlarEntry+ { entryName = ""+ , entryFullName = ""+ , entryType = Folder+ , entrySize = 0+ , entryMtime = Nothing+ }+++{-| Resolve a path inside the archive to its listing entry.+Returns 'Nothing' if the path neither exists as a stored row nor+appears as an implicit folder prefix.+-}+resolvePath :: FilePath -> Text -> Text -> IO (Maybe SqlarEntry)+resolvePath dbPath tableName path+ | T.null path = pure (Just rootEntry)+ | otherwise = do+ let canon =+ if T.isSuffixOf "/" path && T.length path > 1+ then T.dropEnd 1 path+ else path+ (parent, name) = T.breakOnEnd "/" canon+ entries <- listAt dbPath tableName parent+ pure $ List.find (\e -> e.entryName == name) entries+++{-| True if a path exists in the archive, either as an explicit+entry or as an implicit folder containing other entries.+-}+hasPath :: FilePath -> Text -> Text -> IO Bool+hasPath dbPath tableName path+ | T.null path = pure True+ | otherwise = withConnection dbPath $ \conn -> do+ let canon =+ if T.isSuffixOf "/" path && T.length path > 1+ then T.dropEnd 1 path+ else path+ q =+ Query $+ "SELECT 1 FROM "+ <> quoteIdent tableName+ <> " WHERE name = ? OR name = ? OR name LIKE ? LIMIT 1"+ rows :: [Only Int] <-+ query conn q (canon, canon <> "/", canon <> "/%")+ pure $ not (List.null rows)+++{-| Decompress a data cell against its declared size.+If @sz@ equals the blob length, the data is stored uncompressed.+-}+decompressData :: SQLData -> Integer -> ByteString+decompressData sqlData declaredSize =+ case sqlData of+ SQLBlob bs+ | fromIntegral (BS.length bs) == declaredSize -> bs+ | declaredSize <= 0 -> bs+ | otherwise ->+ BL.toStrict (Zlib.decompress (BL.fromStrict bs))+ SQLText t -> T.encodeUtf8 t+ _ -> BS.empty+++-- | Insert or replace an archive entry (stored uncompressed).+insertEntry ::+ FilePath ->+ Text ->+ Text ->+ Int ->+ Integer ->+ ByteString ->+ IO ()+insertEntry dbPath tableName name mode mtime payload =+ withConnection dbPath $ \conn -> do+ let sz = fromIntegral (BS.length payload) :: Integer+ q =+ Query $+ "INSERT OR REPLACE INTO "+ <> quoteIdent tableName+ <> " (name, mode, mtime, sz, data) VALUES (?, ?, ?, ?, ?)"+ execute conn q (name, mode, mtime, sz, SQLBlob payload)+++-- | Delete a single archive entry by exact name.+deleteEntry :: FilePath -> Text -> Text -> IO ()+deleteEntry dbPath tableName name =+ withConnection dbPath $ \conn -> do+ let canon =+ if T.isSuffixOf "/" name && T.length name > 1+ then T.dropEnd 1 name+ else name+ q =+ Query $+ "DELETE FROM "+ <> quoteIdent tableName+ <> " WHERE name = ? OR name = ?"+ execute conn q (canon, canon <> "/")+++-- | Delete everything under a folder path (recursive).+deleteSubtree :: FilePath -> Text -> Text -> IO ()+deleteSubtree dbPath tableName prefix =+ withConnection dbPath $ \conn -> do+ let canon =+ if T.isSuffixOf "/" prefix && T.length prefix > 1+ then T.dropEnd 1 prefix+ else prefix+ q =+ Query $+ "DELETE FROM "+ <> quoteIdent tableName+ <> " WHERE name = ? OR name = ? OR name LIKE ?"+ execute conn q (canon, canon <> "/", canon <> "/%")+++{-| Return the parent archive path of @path@. Empty for archive-root+children. Trailing slashes are stripped before computing the parent.+-}+parentPath :: Text -> Text+parentPath path =+ let canon =+ if T.isSuffixOf "/" path && T.length path > 1+ then T.dropEnd 1 path+ else path+ (before, _) = T.breakOnEnd "/" canon+ in T.dropWhileEnd (== '/') before+++{-| True when the parent collection of @path@ exists in the archive.+The archive root is treated as always existing.+-}+parentExists :: FilePath -> Text -> Text -> IO Bool+parentExists dbPath tableName path = do+ let parent = parentPath path+ if T.null parent+ then pure True+ else hasPath dbPath tableName parent+++{-| Copy every row whose name matches @srcPath@ (or lies underneath+it) so that the @srcPath@ prefix is replaced with @dstPath@. Rows+are inserted with @INSERT OR REPLACE@, so an existing destination+subtree is overwritten by the copy.+-}+copySubtree :: FilePath -> Text -> Text -> Text -> IO ()+copySubtree dbPath tableName srcPath dstPath =+ withConnection dbPath $ \conn -> do+ let srcCanon =+ if T.isSuffixOf "/" srcPath && T.length srcPath > 1+ then T.dropEnd 1 srcPath+ else srcPath+ dstCanon =+ if T.isSuffixOf "/" dstPath && T.length dstPath > 1+ then T.dropEnd 1 dstPath+ else dstPath+ selectQ =+ Query $+ "SELECT name, mode, mtime, sz, data FROM "+ <> quoteIdent tableName+ <> " WHERE name = ? OR name = ? OR name LIKE ?"+ insertQ =+ Query $+ "INSERT OR REPLACE INTO "+ <> quoteIdent tableName+ <> " (name, mode, mtime, sz, data) VALUES (?, ?, ?, ?, ?)"+ rows :: [(Text, SQLData, SQLData, SQLData, SQLData)] <-+ query conn selectQ (srcCanon, srcCanon <> "/", srcCanon <> "/%")+ for_ rows $ \(name, modeData, mtimeData, szData, dataCol) -> do+ let newName = case T.stripPrefix srcCanon name of+ Just rest -> dstCanon <> rest+ Nothing -> name+ execute conn insertQ (newName, modeData, mtimeData, szData, dataCol)+++-- Helpers --------------------------------------------------------------------++szIsZero :: SQLData -> Bool+szIsZero (SQLInteger 0) = True+szIsZero SQLNull = True+szIsZero _ = False+++sqlInt :: SQLData -> Integer+sqlInt (SQLInteger i) = fromIntegral i+sqlInt _ = 0+++sqlMtime :: SQLData -> Maybe UTCTime+sqlMtime (SQLInteger i) = Just (posixSecondsToUTCTime (fromIntegral i))+sqlMtime _ = Nothing+++-- | True when @mode@ encodes a Unix directory (S_IFMT bits = S_IFDIR).+isDirMode :: SQLData -> Bool+isDirMode (SQLInteger i) = (fromIntegral i .&. 0o170000) == (0o040000 :: Int)+isDirMode _ = False+++escDoubleQuotes :: Text -> Text+escDoubleQuotes = T.replace "\"" "\"\""+++quoteIdent :: Text -> Text+quoteIdent kw = "\"" <> escDoubleQuotes kw <> "\""
+ src/SQLiteDAV/Server.hs view
@@ -0,0 +1,2082 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use list comprehension" #-}+{-# HLINT ignore "Use unless" #-}++module SQLiteDAV.Server where++import Protolude (+ Bool (False, True),+ Char,+ Double,+ Either (..),+ Eq,+ FilePath,+ IO,+ Int,+ Integer,+ Maybe,+ Num (fromInteger),+ Show,+ Traversable (traverse),+ concat,+ concatMap,+ elem,+ filter,+ fmap,+ fromIntegral,+ fromMaybe,+ fst,+ intercalate,+ lastMay,+ mapM,+ mempty,+ not,+ notElem,+ null,+ otherwise,+ pure,+ readMaybe,+ sequence,+ show,+ snd,+ truncate,+ zip,+ ($),+ (&&),+ (++),+ (-),+ (.),+ (/=),+ (<>),+ (==),+ (>),+ (||),+ )++import Control.Exception (throw)+import Control.Monad (replicateM, unless, when)+import Control.Monad.Catch (catchAll)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.ByteString (ByteString)+import Data.ByteString qualified as ByteString+import Data.ByteString.Char8 qualified as Char8+import Data.ByteString.Lazy qualified as BL+import Data.Char (isSpace)+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.List (isInfixOf, isPrefixOf)+import Data.Maybe (Maybe (..), catMaybes, isJust, isNothing, mapMaybe)+import Data.Text (Text, toLower)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Time (FormatTime, UTCTime, defaultTimeLocale, formatTime)+import Data.Traversable (for)+import Database.SQLite.Simple (+ Query (Query),+ SQLData (..),+ columnCount,+ columnName,+ execute,+ query,+ query_,+ withConnection,+ withStatement,+ )+import Database.SQLite.Simple.Types (Only (Only))+import Debug.Trace (traceM)+import Network.HTTP.Types.URI (urlDecode)+import Network.Wai.Middleware.AddHeaders (addHeaders)+import Network.Wai.Middleware.Servant.Options (provideOptions)+import Servant (+ Application,+ Handler,+ Header,+ Headers,+ NoContent (NoContent),+ Server,+ ServerError (..),+ addHeader,+ err400,+ err403,+ err404,+ err405,+ err409,+ err412,+ err415,+ err502,+ errBody,+ noHeader,+ serve,+ throwError,+ (:<|>) ((:<|>)),+ )+import System.Directory (+ copyFile,+ createDirectory,+ doesDirectoryExist,+ doesFileExist,+ getModificationTime,+ listDirectory,+ removePathForcibly,+ renamePath,+ )+import System.FilePath (dropExtension)+import Text.XML.Light (+ Content (Elem),+ Element (elContent, elName),+ QName (qName),+ )++import SQLiteDAV.API (WebDavAPI, WithContentType (..), webDavAPI)+import SQLiteDAV.MimeDetect (detectMimeType, extensionForMime)+import SQLiteDAV.Properties (+ ItemType (File, Folder),+ LockResult (LockResult, lockRoot, lockToken),+ PropResults (PropResults, itemType, propMissing, propName, props),+ )+import SQLiteDAV.SQLAR qualified as SQLAR+import SQLiteDAV.Utils (formatTimestamp)++import Data.Time.Clock.POSIX (getPOSIXTime)+++type String = [Char]+++{-| Controls how row directories are named in plain-table URLs.++ * 'RowIdMode' uses the bare rowid (e.g. @/users/1/@). This is the+ historical default and remains the fallback for tables without a+ single-column @PRIMARY KEY@.+ * 'PrimaryKeyMode' uses the value of the primary key column+ (e.g. @/users/john@example.com/@).+ * 'CombinedMode' uses @\<rowid\> - \<pk-value\>@+ (e.g. @/users/1 - john@example.com/@). The rowid prefix keeps+ paths unambiguous even when the PK value contains the separator.+-}+data RowNameMode+ = RowIdMode+ | PrimaryKeyMode+ | CombinedMode+ deriving (Show, Eq)+++{-| Parse a CLI string into a 'RowNameMode'. Accepts a few aliases for+convenience but rejects everything else so typos surface as errors.+-}+parseRowNameMode :: Text -> Maybe RowNameMode+parseRowNameMode raw =+ case T.toLower (T.strip raw) of+ "rowid" -> Just RowIdMode+ "pk" -> Just PrimaryKeyMode+ "primarykey" -> Just PrimaryKeyMode+ "primary-key" -> Just PrimaryKeyMode+ "primary_key" -> Just PrimaryKeyMode+ "combined" -> Just CombinedMode+ _ -> Nothing+++server :: RowNameMode -> FilePath -> Server WebDavAPI+server mode dbPath =+ doMkCol mode dbPath+ :<|> doPropFind mode dbPath+ :<|> doGet mode dbPath+ :<|> doPut mode dbPath+ :<|> doDelete mode dbPath+ :<|> doMove mode dbPath+ :<|> doCopy mode dbPath+ :<|> doLock+ :<|> doUnlock+ :<|> doOptions+++webDavServer :: RowNameMode -> FilePath -> Application+webDavServer mode dbPath =+ addHeaders [("Dav", "1, 2, ordered-collections")] $+ serve webDavAPI (server mode dbPath)+++doOptions :: [String] -> Handler NoContent+doOptions urlPath = do+ pure NoContent+++{-| Strip an optional @scheme://host[:port]@ prefix and split the+remaining path into URL-decoded segments.+-}+parseDestination :: String -> Maybe [String]+parseDestination raw =+ let+ d = T.pack raw+ afterScheme+ | "http://" `T.isPrefixOf` d = T.drop 7 d+ | "https://" `T.isPrefixOf` d = T.drop 8 d+ | otherwise = d+ -- After scheme: "host:port/path/..." or just "/path/...".+ pathOnly =+ if T.null afterScheme || T.head afterScheme == '/'+ then afterScheme+ else T.dropWhile (/= '/') afterScheme+ decoded =+ T.decodeUtf8 (urlDecode False (T.encodeUtf8 pathOnly))+ segments =+ decoded+ & T.splitOn "/"+ & fmap T.unpack+ & filter (not . null)+ in+ Just segments+++{-| RFC 4918 mandates 204 No Content when COPY/MOVE replaces an+existing resource. Servant's verb-derived status applies only when+the handler returns normally, so we 'throwError' a success-shaped+ServerError to override it.+-}+overwroteResponse :: ServerError+overwroteResponse =+ ServerError+ { errHTTPCode = 204+ , errReasonPhrase = "No Content"+ , errBody = ""+ , errHeaders = []+ }+++{-| True when an Overwrite header instructs the server to overwrite.+Default is overwrite per RFC 4918 §10.6.+-}+overwriteAllowed :: Maybe String -> Bool+overwriteAllowed Nothing = True+overwriteAllowed (Just hdr) =+ case [c | c <- hdr, not (isSpace c)] of+ "F" -> False+ "f" -> False+ _ -> True+++-- | True when a Depth header asks for a shallow operation (Depth: 0).+isDepthZero :: Maybe String -> Bool+isDepthZero Nothing = False+isDepthZero (Just hdr) =+ [c | c <- hdr, not (isSpace c)] == "0"+++{-| Resolve the destination header against the source request and+return the table name and archive path on success. Fails with the+appropriate WebDAV error code if the destination is malformed,+points into a different sqlar table, or its parent does not exist.+-}+resolveSqlarDestination ::+ FilePath ->+ String ->+ Maybe String ->+ Handler (String, Text)+resolveSqlarDestination dbPath srcTable destinationMb = do+ rawDest <- case destinationMb of+ Nothing -> throwError err400{errBody = "Missing Destination header"}+ Just d -> pure d+ dstSegments <- case parseDestination rawDest of+ Just segs@(_ : _) -> pure segs+ _ -> throwError err400{errBody = "Invalid Destination header"}+ let+ dstTable : dstRest = dstSegments+ -- Cross-archive operations are not supported (RFC 4918 §9.9.4+ -- suggests 502 Bad Gateway).+ when (dstTable /= srcTable) $+ throwError err502{errBody = "Cross-archive COPY/MOVE not supported"}+ let dstArchive = SQLAR.archivePath dstRest+ -- Empty dst path means moving onto the archive root, which is not+ -- meaningful here.+ when (T.null dstArchive) $+ throwError err403{errBody = "Cannot operate on archive root"}+ parentOk <-+ liftIO $ SQLAR.parentExists dbPath (T.pack dstTable) dstArchive+ unless parentOk $+ throwError err409{errBody = "Destination parent does not exist"}+ pure (dstTable, dstArchive)+++doMove ::+ RowNameMode ->+ FilePath ->+ [String] ->+ Maybe String ->+ Maybe String ->+ Handler NoContent+doMove mode dbPath urlPath destinationMb overwriteMb = do+ let urlPathNorm = urlPath & filter (/= "")+ case urlPathNorm of+ tableName : rest@(_ : _) -> do+ isSqlar <- liftIO $ SQLAR.isSqlarTable dbPath (T.pack tableName)+ if isSqlar+ then doMoveSqlar dbPath tableName rest destinationMb overwriteMb+ else doMovePlain mode dbPath tableName rest destinationMb overwriteMb+ _ ->+ throwError err404{errBody = "Source not found"}+++doMoveSqlar ::+ FilePath ->+ String ->+ [String] ->+ Maybe String ->+ Maybe String ->+ Handler NoContent+doMoveSqlar dbPath tableName rest destinationMb overwriteMb = do+ let srcArchive = SQLAR.archivePath rest+ srcEntry <-+ liftIO $ SQLAR.resolvePath dbPath (T.pack tableName) srcArchive+ when (isNothing srcEntry) $+ throwError err404{errBody = "Source not found"}+ (_, dstArchive) <- resolveSqlarDestination dbPath tableName destinationMb+ -- 412 when the destination exists and Overwrite: F.+ dstExists <- liftIO $ SQLAR.hasPath dbPath (T.pack tableName) dstArchive+ when (dstExists && not (overwriteAllowed overwriteMb)) $+ throwError err412{errBody = "Destination exists and Overwrite: F"}+ -- Per RFC 4918 §9.9.3, MOVE always behaves as Depth: infinity, and an+ -- overwrite replaces any prior subtree at the destination.+ when dstExists $+ liftIO $+ SQLAR.deleteSubtree dbPath (T.pack tableName) dstArchive+ liftIO $ SQLAR.copySubtree dbPath (T.pack tableName) srcArchive dstArchive+ liftIO $ SQLAR.deleteSubtree dbPath (T.pack tableName) srcArchive+ when dstExists $ throwError overwroteResponse+ pure NoContent+++doCopy ::+ RowNameMode ->+ FilePath ->+ [String] ->+ Maybe String ->+ Maybe String ->+ Maybe String ->+ Handler NoContent+doCopy mode dbPath urlPath destinationMb overwriteMb depthMb = do+ let urlPathNorm = urlPath & filter (/= "")+ case urlPathNorm of+ tableName : rest@(_ : _) -> do+ isSqlar <- liftIO $ SQLAR.isSqlarTable dbPath (T.pack tableName)+ if isSqlar+ then+ doCopySqlar+ dbPath+ tableName+ rest+ destinationMb+ overwriteMb+ depthMb+ else+ doCopyPlain mode dbPath tableName rest destinationMb overwriteMb+ _ ->+ throwError err404{errBody = "Source not found"}+++doCopySqlar ::+ FilePath ->+ String ->+ [String] ->+ Maybe String ->+ Maybe String ->+ Maybe String ->+ Handler NoContent+doCopySqlar dbPath tableName rest destinationMb overwriteMb depthMb = do+ let srcArchive = SQLAR.archivePath rest+ srcEntry <-+ liftIO $ SQLAR.resolvePath dbPath (T.pack tableName) srcArchive+ entry <- case srcEntry of+ Nothing -> throwError err404{errBody = "Source not found"}+ Just e -> pure e+ (_, dstArchive) <- resolveSqlarDestination dbPath tableName destinationMb+ dstExists <- liftIO $ SQLAR.hasPath dbPath (T.pack tableName) dstArchive+ when (dstExists && not (overwriteAllowed overwriteMb)) $+ throwError err412{errBody = "Destination exists and Overwrite: F"}+ when dstExists $+ liftIO $+ SQLAR.deleteSubtree dbPath (T.pack tableName) dstArchive+ case SQLAR.entryType entry of+ Folder | isDepthZero depthMb -> do+ -- RFC 4918 §9.8.3: Depth: 0 on a collection copies the collection+ -- itself, not its members. Create a fresh empty folder entry.+ now <- liftIO getPOSIXTime+ liftIO $+ SQLAR.insertEntry+ dbPath+ (T.pack tableName)+ dstArchive+ 0o040755+ (truncate now)+ ByteString.empty+ _ ->+ liftIO $+ SQLAR.copySubtree dbPath (T.pack tableName) srcArchive dstArchive+ when dstExists $ throwError overwroteResponse+ pure NoContent+++{-| Parse the source and destination into a 'PlainTarget' for COPY/MOVE.++The same plain-mode COPY/MOVE rules apply to both methods: source+and destination must live in the same table and have the same+"shape" (cell-to-cell or row-to-row).+-}+data PlainTarget+ = PlainCell {plainRowid :: Integer, plainColumn :: Text}+ | PlainRow {plainRowid :: Integer}+ deriving (Show, Eq)+++{-| Parse a path tail into a 'PlainTarget'. Resolving the rowid is+done in IO because PK-mode lookups require a database query; the+returned 'Either' threads the structural validation result back to+the caller while keeping the rowid resolution synchronous.+-}+parsePlainTarget ::+ RowNameMode ->+ FilePath ->+ Text ->+ [String] ->+ IO (Either Text PlainTarget)+parsePlainTarget mode dbPath table segs =+ case filter (/= "") segs of+ [rowidStr] -> do+ rMb <- resolveRowid mode dbPath table rowidStr+ pure $ case rMb of+ Just r -> Right (PlainRow r)+ Nothing -> Left "Invalid rowid in path"+ [rowidStr, colNameWithExt] -> do+ rMb <- resolveRowid mode dbPath table rowidStr+ pure $ case rMb of+ Just r ->+ Right (PlainCell r (T.pack (dropExtension colNameWithExt)))+ Nothing -> Left "Invalid rowid in path"+ _ -> pure (Left "Path does not name a row or cell")+++resolvePlainDestination ::+ RowNameMode ->+ FilePath ->+ String ->+ Maybe String ->+ Handler (String, PlainTarget)+resolvePlainDestination mode dbPath srcTable destinationMb = do+ rawDest <- case destinationMb of+ Nothing -> throwError err400{errBody = "Missing Destination header"}+ Just d -> pure d+ dstSegments <- case parseDestination rawDest of+ Just segs@(_ : _) -> pure segs+ _ -> throwError err400{errBody = "Invalid Destination header"}+ let dstTable : dstRest = dstSegments+ when (dstTable /= srcTable) $+ throwError+ err502{errBody = "Cross-table COPY/MOVE not supported"}+ parsed <- liftIO $ parsePlainTarget mode dbPath (T.pack dstTable) dstRest+ target <- case parsed of+ Left msg -> throwError err400{errBody = BL.fromStrict (T.encodeUtf8 msg)}+ Right t -> pure t+ pure (dstTable, target)+++{-| COPY in plain mode supports cell→cell and row→row copies inside+the same table. Cross-table or shape-mismatched destinations are+rejected.+-}+doCopyPlain ::+ RowNameMode ->+ FilePath ->+ String ->+ [String] ->+ Maybe String ->+ Maybe String ->+ Handler NoContent+doCopyPlain mode dbPath tableName rest destinationMb overwriteMb = do+ parsedSrc <- liftIO $ parsePlainTarget mode dbPath (T.pack tableName) rest+ src <- case parsedSrc of+ Left msg -> throwError err400{errBody = BL.fromStrict (T.encodeUtf8 msg)}+ Right t -> pure t+ (_, dst) <- resolvePlainDestination mode dbPath tableName destinationMb+ -- A no-op COPY onto itself is explicitly forbidden by RFC 4918.+ when (src == dst) $+ throwError err403{errBody = "Source and destination are identical"}+ let table = T.pack tableName+ tableOk <- liftIO $ tableExists dbPath table+ unless tableOk $+ throwError err404{errBody = "Table does not exist"}+ copyOrMovePlain dbPath table src dst overwriteMb False+++{-| MOVE in plain mode = COPY + clear source. The source is set to+NULL for cells or DELETEd for rows.+-}+doMovePlain ::+ RowNameMode ->+ FilePath ->+ String ->+ [String] ->+ Maybe String ->+ Maybe String ->+ Handler NoContent+doMovePlain mode dbPath tableName rest destinationMb overwriteMb = do+ parsedSrc <- liftIO $ parsePlainTarget mode dbPath (T.pack tableName) rest+ src <- case parsedSrc of+ Left msg -> throwError err400{errBody = BL.fromStrict (T.encodeUtf8 msg)}+ Right t -> pure t+ (_, dst) <- resolvePlainDestination mode dbPath tableName destinationMb+ when (src == dst) $+ throwError err403{errBody = "Source and destination are identical"}+ let table = T.pack tableName+ tableOk <- liftIO $ tableExists dbPath table+ unless tableOk $+ throwError err404{errBody = "Table does not exist"}+ copyOrMovePlain dbPath table src dst overwriteMb True+++{-| Shared core for plain-mode COPY/MOVE.++@isMove@ controls whether the source is cleared after the+destination is written.+-}+copyOrMovePlain ::+ FilePath ->+ Text ->+ PlainTarget ->+ PlainTarget ->+ Maybe String ->+ Bool ->+ Handler NoContent+copyOrMovePlain dbPath table src dst overwriteMb isMove =+ case (src, dst) of+ (PlainCell srcRow srcCol, PlainCell dstRow dstCol) -> do+ ensureColumns [srcCol, dstCol]+ srcRowOk <- liftIO $ rowExists dbPath table srcRow+ unless srcRowOk $ throwError err404{errBody = "Source row missing"}+ dstRowOk <- liftIO $ rowExists dbPath table dstRow+ unless dstRowOk $ throwError err409{errBody = "Destination row missing"}+ srcVal <- liftIO $ readCell dbPath table srcRow srcCol+ value <- case srcVal of+ Nothing -> throwError err404{errBody = "Source cell missing"}+ Just v -> pure v+ dstWasFilled <- do+ existing <- liftIO $ readCell dbPath table dstRow dstCol+ pure $ case existing of+ Just SQLNull -> False+ Just _ -> True+ Nothing -> False+ when (dstWasFilled && not (overwriteAllowed overwriteMb)) $+ throwError err412{errBody = "Destination cell has content and Overwrite: F"}+ liftIO $ updateCell dbPath table dstRow dstCol value+ when isMove $+ -- For MOVE, clear the source cell. Skipped when the move is+ -- between the same column in the same row (already prevented+ -- by the src == dst check above).+ liftIO $+ updateCell dbPath table srcRow srcCol SQLNull+ when dstWasFilled $ throwError overwroteResponse+ pure NoContent+ (PlainRow srcRow, PlainRow dstRow) -> do+ srcRowOk <- liftIO $ rowExists dbPath table srcRow+ unless srcRowOk $ throwError err404{errBody = "Source row missing"}+ dstRowOk <- liftIO $ rowExists dbPath table dstRow+ when (dstRowOk && not (overwriteAllowed overwriteMb)) $+ throwError err412{errBody = "Destination row exists and Overwrite: F"}+ liftIO $ cloneRow dbPath table srcRow dstRow+ when isMove $+ liftIO $+ deleteRow dbPath table srcRow+ when dstRowOk $ throwError overwroteResponse+ pure NoContent+ _ ->+ throwError+ err403{errBody = "Plain COPY/MOVE requires matching shapes"}+ where+ ensureColumns cols = do+ knownCols <- liftIO $ listColumnNames dbPath table+ let missing = filter (`notElem` knownCols) cols+ unless (null missing) $+ throwError err404{errBody = "Unknown column in path"}+++-- Locks are not tracked; the fake token only satisfies clients+-- (e.g. macOS Finder) that require LOCK before issuing a PUT.+fakeLockToken :: String+fakeLockToken = "urn:uuid:00000000-0000-0000-0000-000000000001"+++doLock ::+ [String] ->+ Handler (Headers '[Header "Lock-Token" String] LockResult)+doLock urlPath = do+ let+ root = "/" ++ intercalate "/" urlPath+ lockResult =+ LockResult{lockToken = fakeLockToken, lockRoot = root}+ pure $ addHeader ("<" ++ fakeLockToken ++ ">") lockResult+++doUnlock :: [String] -> Maybe String -> Handler NoContent+doUnlock urlPath tokenMb = do+ traceM $ show urlPath ++ " unlocked with token " ++ show tokenMb+ pure NoContent+++doPut ::+ RowNameMode ->+ FilePath ->+ [String] ->+ ByteString ->+ Handler NoContent+doPut mode dbPath urlPath body = do+ let urlPathNorm = urlPath & filter (/= "")+ case urlPathNorm of+ tableName : rest@(_ : _) -> do+ isSqlar <- liftIO $ SQLAR.isSqlarTable dbPath (T.pack tableName)+ if isSqlar+ then doPutSqlar dbPath tableName rest body+ else doPutPlain mode dbPath tableName rest body+ _ ->+ throwError err405{errBody = "PUT requires a file path"}+++doPutSqlar :: FilePath -> String -> [String] -> ByteString -> Handler NoContent+doPutSqlar dbPath tableName rest body = do+ let archive = SQLAR.archivePath rest+ -- RFC 4918 §9.7.1: PUT requires the parent collection to exist.+ parentOk <-+ liftIO $ SQLAR.parentExists dbPath (T.pack tableName) archive+ unless parentOk $+ throwError err409{errBody = "Parent collection does not exist"}+ -- A PUT onto an existing collection is not meaningful for a file.+ existing <-+ liftIO $ SQLAR.resolvePath dbPath (T.pack tableName) archive+ case existing of+ Just e+ | SQLAR.entryType e == Folder ->+ throwError err405{errBody = "Path is a collection"}+ _ -> pure ()+ now <- liftIO getPOSIXTime+ let+ -- 0o100644 == regular file with 0644 perms+ mode :: Integer+ mode = 0o100644+ liftIO $+ SQLAR.insertEntry+ dbPath+ (T.pack tableName)+ archive+ (fromInteger mode)+ (truncate now)+ body+ pure NoContent+++{-| PUT in plain mode writes a single cell. Only the cell shape+@/table/rowid/col.ext@ is supported; other depths are rejected+because the row/column model has no analogue for nested files.+-}+doPutPlain ::+ RowNameMode ->+ FilePath ->+ String ->+ [String] ->+ ByteString ->+ Handler NoContent+doPutPlain mode dbPath tableName rest body = do+ case rest & filter (/= "") of+ [rowidStr, colNameWithExt] -> do+ tableOk <- liftIO $ tableExists dbPath (T.pack tableName)+ unless tableOk $+ throwError err404{errBody = "Table does not exist"}+ rMb <- liftIO $ resolveRowid mode dbPath (T.pack tableName) rowidStr+ rowid <- case rMb of+ Nothing -> throwError err400{errBody = "Invalid rowid"}+ Just r -> pure r+ let colName = T.pack (dropExtension colNameWithExt)+ declaredType <-+ liftIO $ lookupColumnType dbPath (T.pack tableName) colName+ affinity <- case declaredType of+ Nothing -> throwError err404{errBody = "Column does not exist"}+ Just t -> pure (affinityFromDeclared t)+ rowOk <- liftIO $ rowExists dbPath (T.pack tableName) rowid+ unless rowOk $+ throwError err409{errBody = "Row does not exist"}+ wasNull <- liftIO $ cellIsNull dbPath (T.pack tableName) rowid colName+ liftIO $+ updateCell+ dbPath+ (T.pack tableName)+ rowid+ colName+ (coerceBody affinity body)+ unless wasNull $ throwError overwroteResponse+ pure NoContent+ _ ->+ throwError+ err405{errBody = "Plain-table PUT requires /table/rowid/col"}+++dataToContentType :: SQLData -> IO BL.ByteString+dataToContentType sqlData =+ case sqlData of+ SQLText _ -> pure "text/plain"+ SQLInteger _ -> pure "text/plain"+ SQLFloat _ -> pure "text/plain"+ SQLBlob blob -> do+ mime <- detectMimeType blob+ pure $ BL.fromStrict $ T.encodeUtf8 mime+ SQLNull -> pure "text/plain"+++dataToFileExt :: SQLData -> IO String+dataToFileExt sqlData =+ case sqlData of+ SQLText _ -> pure ".txt"+ SQLInteger _ -> pure ".txt"+ SQLFloat _ -> pure ".txt"+ SQLBlob blob -> do+ mime <- detectMimeType blob+ pure $ case extensionForMime mime of+ Just ext -> "." <> T.unpack ext+ Nothing -> ""+ SQLNull -> pure ".txt"+++doGet ::+ RowNameMode ->+ FilePath ->+ [String] ->+ Handler WithContentType+doGet mode dbPath urlPath = do+ let urlPathNorm = urlPath & filter (/= "")+ case urlPathNorm of+ tableName : rest@(_ : _) -> do+ isSqlar <- liftIO $ SQLAR.isSqlarTable dbPath (T.pack tableName)+ if isSqlar+ then doGetSqlar dbPath tableName rest+ else do+ -- Probing a non-existent table would otherwise crash with a+ -- SQLite "no such table" exception; report 404 instead.+ tableOk <- liftIO $ tableExists dbPath (T.pack tableName)+ unless tableOk $+ throwError err404{errBody = "Table not found"}+ case rest of+ rowidStr : colNameWithExt : _rest -> do+ let colName = T.pack (dropExtension colNameWithExt)+ colOk <-+ liftIO $ columnExists dbPath (T.pack tableName) colName+ unless colOk $+ throwError err404{errBody = "Column not found"}+ doGetCell mode dbPath tableName rowidStr colNameWithExt+ _ -> throwError err404+ _ ->+ throwError err404+++doGetCell ::+ RowNameMode ->+ FilePath ->+ String ->+ String ->+ String ->+ Handler WithContentType+doGetCell mode dbPath tableName rowidStr colNameWithExt = do+ rMb <- liftIO $ resolveRowid mode dbPath (T.pack tableName) rowidStr+ case rMb of+ Nothing ->+ throwError err400{errBody = "Invalid rowid"}+ Just (rowid :: Integer) -> do+ colResult <- liftIO $ withConnection dbPath $ \conn -> do+ let+ colName = dropExtension colNameWithExt+ sqlQuery =+ Query $+ "SELECT "+ <> quoteKeyword (T.pack colName)+ <> " FROM "+ <> quoteKeyword (T.pack tableName)+ <> " WHERE rowid == ?"+ query conn sqlQuery (Only rowid)++ case colResult :: [Only SQLData] of+ [] ->+ throwError err404{errBody = "Row not found"}+ [Only colData] -> do+ contentType <- liftIO $ dataToContentType colData+ pure $+ WithContentType+ { header = contentType+ , content = colData+ }+ _ ->+ throwError+ err400+ { errBody = "Multiple rows with the same rowid exist"+ }+++doGetSqlar :: FilePath -> String -> [String] -> Handler WithContentType+doGetSqlar dbPath tableName rest = do+ let archive = SQLAR.archivePath rest+ fileMb <- liftIO $ SQLAR.lookupEntry dbPath (T.pack tableName) archive+ case fileMb of+ Nothing ->+ throwError err404{errBody = "File not found in archive"}+ Just file -> do+ mime <- liftIO $ detectMimeType (SQLAR.fileContent file)+ pure $+ WithContentType+ { header = BL.fromStrict (T.encodeUtf8 mime)+ , content = SQLBlob (SQLAR.fileContent file)+ }+++getCellSize ::+ RowNameMode ->+ FilePath ->+ [String] ->+ Handler Integer+getCellSize mode dbPath urlPath = do+ case urlPath of+ tableName : rowidStr : colNameWithExt : _rest -> do+ rMb <- liftIO $ resolveRowid mode dbPath (T.pack tableName) rowidStr+ case rMb of+ Nothing ->+ throwError err400{errBody = "Invalid rowid"}+ Just (rowid :: Integer) -> do+ colResult <- liftIO $ withConnection dbPath $ \conn -> do+ let+ colName = dropExtension colNameWithExt+ sqlQuery =+ Query $+ "SELECT length("+ <> quoteKeyword (T.pack colName)+ <> ") FROM "+ <> quoteKeyword (T.pack tableName)+ <> " WHERE rowid == ?"+ query conn sqlQuery (Only rowid)++ case colResult :: [Only SQLData] of+ [] ->+ throwError err404{errBody = "Row not found"}+ [Only colData] ->+ case colData of+ SQLInteger size ->+ pure $ fromIntegral size+ _ ->+ throwError err400{errBody = "Column is not an integer"}+ _ ->+ throwError+ err400+ { errBody = "Multiple rows with the same rowid exist"+ }+ _ ->+ pure 0+++doDelete ::+ RowNameMode ->+ FilePath ->+ [String] ->+ Handler NoContent+doDelete mode dbPath urlPath = do+ let urlPathNorm = urlPath & filter (/= "")+ case urlPathNorm of+ tableName : rest -> do+ isSqlar <- liftIO $ SQLAR.isSqlarTable dbPath (T.pack tableName)+ if isSqlar+ then doDeleteSqlar dbPath tableName rest+ else doDeletePlain mode dbPath tableName rest+ _ ->+ throwError err403{errBody = "Cannot DELETE the database root"}+++doDeleteSqlar :: FilePath -> String -> [String] -> Handler NoContent+doDeleteSqlar dbPath tableName rest = do+ let archive = SQLAR.archivePath rest+ case rest & filter (/= "") of+ [] -> do+ -- DELETE on the sqlar table itself drops it.+ tableOk <- liftIO $ tableExists dbPath (T.pack tableName)+ unless tableOk $+ throwError err404{errBody = "Table does not exist"}+ liftIO $ dropTable dbPath (T.pack tableName)+ pure NoContent+ _ -> do+ exists <- liftIO $ SQLAR.hasPath dbPath (T.pack tableName) archive+ unless exists $+ throwError err404{errBody = "Path not found in archive"}+ liftIO $ SQLAR.deleteSubtree dbPath (T.pack tableName) archive+ pure NoContent+++{-| DELETE in plain mode dispatches by URL depth:++ * one segment (@/table/@) drops the table;+ * two segments (@/table/rowid@) deletes the row;+ * three segments (@/table/rowid/col@) sets the cell to NULL.+-}+doDeletePlain ::+ RowNameMode ->+ FilePath ->+ String ->+ [String] ->+ Handler NoContent+doDeletePlain mode dbPath tableName rest =+ case rest & filter (/= "") of+ [] -> do+ tableOk <- liftIO $ tableExists dbPath (T.pack tableName)+ unless tableOk $+ throwError err404{errBody = "Table does not exist"}+ liftIO $ dropTable dbPath (T.pack tableName)+ pure NoContent+ [rowidStr] -> do+ tableOk <- liftIO $ tableExists dbPath (T.pack tableName)+ unless tableOk $+ throwError err404{errBody = "Table does not exist"}+ rMb <- liftIO $ resolveRowid mode dbPath (T.pack tableName) rowidStr+ rowid <- case rMb of+ Nothing -> throwError err400{errBody = "Invalid rowid"}+ Just r -> pure r+ rowOk <- liftIO $ rowExists dbPath (T.pack tableName) rowid+ unless rowOk $+ throwError err404{errBody = "Row does not exist"}+ liftIO $ deleteRow dbPath (T.pack tableName) rowid+ pure NoContent+ [rowidStr, colNameWithExt] -> do+ tableOk <- liftIO $ tableExists dbPath (T.pack tableName)+ unless tableOk $+ throwError err404{errBody = "Table does not exist"}+ let colName = T.pack (dropExtension colNameWithExt)+ colOk <- liftIO $ columnExists dbPath (T.pack tableName) colName+ unless colOk $+ throwError err404{errBody = "Column does not exist"}+ rMb <- liftIO $ resolveRowid mode dbPath (T.pack tableName) rowidStr+ rowid <- case rMb of+ Nothing -> throwError err400{errBody = "Invalid rowid"}+ Just r -> pure r+ rowOk <- liftIO $ rowExists dbPath (T.pack tableName) rowid+ unless rowOk $+ throwError err404{errBody = "Row does not exist"}+ liftIO $+ updateCell dbPath (T.pack tableName) rowid colName SQLNull+ pure NoContent+ _ ->+ throwError err404{errBody = "Path does not exist"}+++doMkCol ::+ RowNameMode ->+ FilePath ->+ [String] ->+ Maybe Integer ->+ Handler NoContent+doMkCol mode dbPath urlPath contentLengthMb = do+ -- RFC 4918 §9.3: MKCOL with a non-empty body must be rejected with 415.+ -- We treat a positive Content-Length as the unambiguous signal of a body+ -- (clients without bodies send 0 or omit the header).+ case contentLengthMb of+ Just n+ | n > 0 ->+ throwError err415{errBody = "MKCOL must have an empty body"}+ _ -> pure ()+ let urlPathNorm = urlPath & filter (/= "")+ case urlPathNorm of+ [] ->+ throwError err405{errBody = "Cannot MKCOL on the database root"}+ tableName : rest -> do+ tableOk <- liftIO $ tableExists dbPath (T.pack tableName)+ if not tableOk+ then case rest & filter (/= "") of+ [] -> do+ -- /newtable/ : create the table itself (as a sqlar archive+ -- so subsequent MKCOL/PUT/COPY/MOVE under it work).+ liftIO $ createSqlarTable dbPath (T.pack tableName)+ pure NoContent+ _ ->+ -- Parent table does not exist; ancestors must per RFC 4918.+ throwError err409{errBody = "Parent table does not exist"}+ else do+ isSqlar <- liftIO $ SQLAR.isSqlarTable dbPath (T.pack tableName)+ if isSqlar+ then doMkColSqlar dbPath tableName rest+ else doMkColPlain mode dbPath tableName rest+++doMkColSqlar :: FilePath -> String -> [String] -> Handler NoContent+doMkColSqlar dbPath tableName rest = do+ case rest & filter (/= "") of+ [] ->+ -- The table itself already exists, so the table-level MKCOL+ -- must be rejected (405).+ throwError err405{errBody = "Resource already exists"}+ _ -> pure ()+ let archive = SQLAR.archivePath rest+ -- RFC 4918 §9.3.1: the parent must exist (otherwise 409).+ parentOk <- liftIO $ SQLAR.parentExists dbPath (T.pack tableName) archive+ unless parentOk $+ throwError err409{errBody = "Parent collection does not exist"}+ -- And the path itself must NOT already exist (otherwise 405).+ existing <- liftIO $ SQLAR.resolvePath dbPath (T.pack tableName) archive+ when (isJust existing) $+ throwError err405{errBody = "Resource already exists"}+ now <- liftIO getPOSIXTime+ let+ -- 0o040755 == directory with 0755 perms+ mode :: Integer+ mode = 0o040755+ liftIO $+ SQLAR.insertEntry+ dbPath+ (T.pack tableName)+ archive+ (fromInteger mode)+ (truncate now)+ ByteString.empty+ pure NoContent+++{-| MKCOL in plain mode either drops into 405 (the table already+exists) or inserts a row at a requested rowid. Cell-level MKCOL is+refused because cells aren't collections.+-}+doMkColPlain ::+ RowNameMode ->+ FilePath ->+ String ->+ [String] ->+ Handler NoContent+doMkColPlain mode dbPath tableName rest =+ case rest & filter (/= "") of+ [] ->+ throwError err405{errBody = "Table already exists"}+ [seg] -> do+ pkMb <- liftIO $ singlePkColumn dbPath (T.pack tableName)+ case (mode, pkMb) of+ (PrimaryKeyMode, Just pkCol) ->+ -- Insert a row keyed by the requested PK value.+ mkColByPk dbPath (T.pack tableName) pkCol (T.pack seg)+ _ -> do+ rowid <- case mode of+ CombinedMode ->+ let+ segTxt = T.pack seg+ (pref, restTxt) = T.breakOn " - " segTxt+ rowidPart =+ if T.null restTxt+ then segTxt+ else pref+ in+ case readMaybe (T.unpack rowidPart) of+ Nothing -> throwError err400{errBody = "Invalid rowid"}+ Just r -> pure r+ _ -> case readMaybe seg of+ Nothing -> throwError err400{errBody = "Invalid rowid"}+ Just r -> pure r+ rowOk <- liftIO $ rowExists dbPath (T.pack tableName) rowid+ when rowOk $+ throwError err405{errBody = "Row already exists"}+ inserted <- liftIO $ insertEmptyRow dbPath (T.pack tableName) rowid+ unless inserted $+ throwError+ err409+ { errBody =+ "NOT NULL constraint blocks the insert; "+ <> "use PUT to populate columns first"+ }+ pure NoContent+ _ ->+ throwError+ err403{errBody = "MKCOL is not defined for cells in plain tables"}+++{-| Insert a fresh row keyed by the requested primary-key value. Used+exclusively in 'PrimaryKeyMode' so MKCOL targets are addressable by+the same URL segment that names the row in PROPFIND listings.+-}+mkColByPk :: FilePath -> Text -> Text -> Text -> Handler NoContent+mkColByPk dbPath tableName pkCol pkValue = do+ existing <- liftIO $ findRowidByPk dbPath tableName pkCol pkValue+ when (isJust existing) $+ throwError err405{errBody = "Row already exists"}+ inserted <- liftIO $ insertRowByPk dbPath tableName pkCol pkValue+ unless inserted $+ throwError+ err409+ { errBody =+ "Insert blocked by NOT NULL constraint; "+ <> "use PUT to populate columns first"+ }+ pure NoContent+++propNameToEntry ::+ RowNameMode ->+ FilePath ->+ [String] ->+ ItemType ->+ String ->+ Handler (Maybe (String, String))+propNameToEntry mode dbPath urlPath itemType propName = do+ let urlPathStr = "/" ++ intercalate "/" urlPath++ ( case propName of+ "creationdate" -> pure Nothing -- Unix doesn't store creation date+ "getcontentlength" ->+ if itemType == File+ then getCellSize mode dbPath urlPath <&> Just . show+ else pure Nothing+ "getlastmodified" -> do+ lastModified <- liftIO $ getModificationTime dbPath+ pure $ Just $ formatTimestamp lastModified+ -- "resourcetype" -- Handled by itemType+ _ -> pure Nothing+ )+ <&> (\valIO -> valIO <&> (propName,) . T.unpack)+++keepMissingNames :: ItemType -> [String] -> [String]+keepMissingNames itemType propNames =+ let disallowed =+ [ "creationdate"+ , "quota-available-bytes"+ , "quota-used-bytes"+ , "quota"+ , "quotaused"+ ]+ ++ ( case itemType of+ File -> []+ Folder -> ["getcontentlength"]+ )+ in propNames & filter (`elem` disallowed)+++{-| Stream just the rowids of a table.++The plain-mode PROPFIND on a table only needs the rowids to build each+child folder's href, so projecting the full @SELECT *@ would pull every+column (including BLOBs) into memory — a 5 GiB table OOMs on the first+listing. See GitHub issue #14.+-}+listRowids :: FilePath -> Text -> IO [Integer]+listRowids dbPath tableName =+ catchAll+ ( withConnection dbPath $ \conn -> do+ let sqlQuery = Query $ "SELECT rowid FROM " <> quoteKeyword tableName+ rows :: [Only Integer] <- query_ conn sqlQuery+ pure $ fmap (\(Only r) -> r) rows+ )+ (\_ -> pure [])+++getRowColumns :: FilePath -> Text -> Integer -> IO [(Text, SQLData)]+getRowColumns dbPath tableName rowid =+ catchAll+ ( withConnection dbPath $ \conn -> do+ let sqlQuery =+ Query $+ "SELECT * FROM "+ <> quoteKeyword tableName+ <> " WHERE rowid = ?"++ columns <- withStatement conn sqlQuery $ \stmt -> do+ numCols <- columnCount stmt+ let colNums = [0 .. (numCols - 1)]+ colNums & traverse (columnName stmt)++ tableRows :: [[SQLData]] <- query conn sqlQuery (Only rowid)++ case tableRows of+ [] -> pure []+ [row] -> pure $ row & zip columns+ )+ (\_ -> pure [])+++ignoreHiddenFiles :: String -> Handler ()+ignoreHiddenFiles resourceName =+ when+ ( (".git" `isPrefixOf` resourceName)+ || (".hidden" `isPrefixOf` resourceName)+ || (".metadata_never_index" `isPrefixOf` resourceName)+ || (".ql_disablethumbnails" `isPrefixOf` resourceName)+ || (".Spotlight-V100" `isPrefixOf` resourceName)+ || ("._" `isPrefixOf` resourceName)+ )+ $ throwError err404+++getPropsForTable ::+ RowNameMode ->+ FilePath ->+ [String] ->+ Maybe Text ->+ [String] ->+ String ->+ Handler [PropResults]+getPropsForTable mode dbPath urlPath depth propNames tableName = do+ props <-+ propNames+ & mapM (propNameToEntry mode dbPath urlPath Folder)+ <&> catMaybes++ let+ rootPropResult =+ PropResults+ { propName = tableName+ , itemType = Folder+ , props+ , propMissing = propNames & keepMissingNames Folder+ }+ depthLow = depth <&> toLower++ ignoreHiddenFiles tableName++ rowids <- liftIO $ listRowids dbPath (T.pack tableName)+ rowSegments <-+ liftIO $+ mapM (formatRowSegment mode dbPath (T.pack tableName)) rowids++ let+ ioTableRows =+ rowSegments+ <&> ( \seg ->+ PropResults+ { propName = tableName ++ "/" ++ seg+ , itemType = Folder+ , props+ , propMissing = propNames & keepMissingNames Folder+ }+ )++ pure $+ rootPropResult+ : if depthLow /= Just "1" && depthLow /= Just "infinity"+ then []+ else ioTableRows+++getPropsForRow ::+ RowNameMode ->+ FilePath ->+ [String] ->+ Maybe Text ->+ [String] ->+ String ->+ Maybe Integer ->+ Handler [PropResults]+getPropsForRow mode dbPath urlPath depth propNames tableName rowidMb = do+ rootProps <-+ propNames+ & mapM (propNameToEntry mode dbPath urlPath Folder)+ <&> catMaybes++ let+ rowid = case rowidMb of+ Nothing -> throw $ err404{errBody = "Row not found"}+ Just rowidInteger -> rowidInteger++ rowSegment <-+ liftIO $ formatRowSegment mode dbPath (T.pack tableName) rowid++ let+ rootPropResult =+ PropResults+ { propName = tableName <> "/" <> rowSegment+ , itemType = Folder+ , props = rootProps+ , propMissing = propNames & keepMissingNames Folder+ }+ depthLow = depth <&> toLower++ rowColumns <- liftIO $ getRowColumns dbPath (T.pack tableName) rowid++ when (null rowColumns) $+ throwError+ err404{errBody = "Row does not exist or does not have any columns"}++ propResults <-+ mapM+ ( \rowColumn -> do+ let+ colName = T.unpack (fst rowColumn)+ fileExt <- liftIO $ dataToFileExt (snd rowColumn)+ let+ getPropName tableName =+ tableName+ ++ "/"+ ++ rowSegment+ ++ "/"+ ++ colName+ ++ fileExt++ props <-+ propNames+ & mapM (propNameToEntry mode dbPath (urlPath ++ [colName]) File)+ <&> catMaybes++ pure $+ PropResults+ { propName = getPropName tableName+ , itemType = File+ , props+ , propMissing = propNames & keepMissingNames File+ }+ )+ rowColumns++ pure $+ rootPropResult+ : if depthLow /= Just "1" && depthLow /= Just "infinity"+ then []+ else propResults+++getPropsForCell ::+ RowNameMode ->+ FilePath ->+ [String] ->+ [String] ->+ String ->+ Maybe Integer ->+ String ->+ Handler [PropResults]+getPropsForCell mode dbPath urlPath propNames tableName rowidMb colNameWithExt = do+ props <-+ propNames+ & mapM (propNameToEntry mode dbPath urlPath File)+ <&> catMaybes++ let+ colName = dropExtension colNameWithExt+ rowid = case rowidMb of+ Nothing -> throw $ err404{errBody = "Row not found"}+ Just rowidInteger -> rowidInteger++ rowSegment <-+ liftIO $ formatRowSegment mode dbPath (T.pack tableName) rowid++ let+ rootPropResult =+ PropResults+ { propName = tableName <> "/" <> rowSegment <> "/" <> colName+ , itemType = File+ , props+ , propMissing = propNames & keepMissingNames File+ }++ ignoreHiddenFiles colName++ pure [rootPropResult]+++sqlarPropEntry ::+ FilePath ->+ ItemType ->+ Integer ->+ Maybe UTCTime ->+ String ->+ Handler (Maybe (String, String))+sqlarPropEntry dbPath theItemType size mtime propNameStr =+ case propNameStr of+ "creationdate" -> pure Nothing+ "getcontentlength" ->+ pure $ case theItemType of+ File -> Just (propNameStr, show size)+ Folder -> Nothing+ "getlastmodified" -> do+ txt <- case mtime of+ Just t -> pure (formatTimestamp t)+ Nothing -> do+ dbMtime <- liftIO $ getModificationTime dbPath+ pure (formatTimestamp dbMtime)+ pure $ Just (propNameStr, T.unpack txt)+ _ -> pure Nothing+++sqlarEntryToPropResults ::+ FilePath ->+ [String] ->+ String ->+ SQLAR.SqlarEntry ->+ Handler PropResults+sqlarEntryToPropResults dbPath propNames pName entry = do+ let entryItemType = SQLAR.entryType entry+ pairs <-+ propNames+ & mapM+ ( sqlarPropEntry+ dbPath+ entryItemType+ (SQLAR.entrySize entry)+ (SQLAR.entryMtime entry)+ )+ <&> catMaybes+ pure $+ PropResults+ { propName = pName+ , itemType = entryItemType+ , props = pairs+ , propMissing = propNames & keepMissingNames entryItemType+ }+++getPropsForSqlar ::+ FilePath ->+ Maybe Text ->+ [String] ->+ String ->+ [String] ->+ Handler [PropResults]+getPropsForSqlar dbPath depth propNames tableName restPath = do+ let+ restPathClean = restPath & filter (/= "")+ archive = SQLAR.archivePath restPathClean++ case restPathClean of+ [] -> pure ()+ _ -> ignoreHiddenFiles (fromMaybe "" (lastMay restPathClean))++ resolved <- liftIO $ SQLAR.resolvePath dbPath (T.pack tableName) archive+ case resolved of+ Nothing ->+ throwError err404{errBody = "Path not found in archive"}+ Just entry -> do+ let+ rootHref =+ if T.null archive+ then tableName+ else tableName ++ "/" ++ T.unpack archive+ depthLow = depth <&> toLower+ isDeep = depthLow == Just "1" || depthLow == Just "infinity"+ -- Use the archive-root href when restPath is empty,+ -- which gives the table a folder identity.+ rootEntry = case restPathClean of+ [] -> SQLAR.rootEntry+ _ -> entry++ rootResult <- sqlarEntryToPropResults dbPath propNames rootHref rootEntry++ case SQLAR.entryType entry of+ File -> pure [rootResult]+ Folder+ | not isDeep -> pure [rootResult]+ | otherwise -> do+ children <-+ liftIO $ SQLAR.listAt dbPath (T.pack tableName) archive+ childResults <-+ children+ & mapM+ ( \child -> do+ let childHref =+ tableName+ ++ "/"+ ++ T.unpack (SQLAR.entryFullName child)+ sqlarEntryToPropResults dbPath propNames childHref child+ )+ pure (rootResult : childResults)+++-- | Subset of RFC 8144 / 7240 Prefer header values that the server honors.+data Preferences = Preferences+ { depthNoroot :: Bool+ , returnMinimal :: Bool+ }+++emptyPreferences :: Preferences+emptyPreferences = Preferences{depthNoroot = False, returnMinimal = False}+++parsePrefer :: Maybe Text -> Preferences+parsePrefer Nothing = emptyPreferences+parsePrefer (Just header) =+ let+ tokens =+ header+ & toLower+ & T.splitOn ","+ & fmap (T.takeWhile (/= ';'))+ & fmap (T.filter (not . isSpace))+ in+ Preferences+ { depthNoroot = "depth-noroot" `elem` tokens+ , returnMinimal = "return=minimal" `elem` tokens+ }+++{-| Apply the requested preferences and return what was actually applied.+`depth-noroot` only applies when Depth is "1" or "infinity"+(RFC 8144, Section 2.1).+-}+applyPreferences ::+ Preferences ->+ Maybe Text ->+ [PropResults] ->+ (Preferences, [PropResults])+applyPreferences prefs depth results =+ let+ depthLow = depth <&> toLower+ isDepthHigh = depthLow == Just "1" || depthLow == Just "infinity"+ dropRoot = prefs.depthNoroot && isDepthHigh+ afterRoot = case (dropRoot, results) of+ (True, _ : rest) -> rest+ _ -> results+ afterMinimal =+ if prefs.returnMinimal+ then afterRoot <&> \r -> r{propMissing = []}+ else afterRoot+ appliedPrefs =+ Preferences+ { depthNoroot = dropRoot+ , returnMinimal = prefs.returnMinimal+ }+ in+ (appliedPrefs, afterMinimal)+++preferenceAppliedHeader :: Preferences -> Maybe String+preferenceAppliedHeader prefs =+ let+ parts =+ ["depth-noroot" | prefs.depthNoroot]+ ++ ["return=minimal" | prefs.returnMinimal]+ in+ case parts of+ [] -> Nothing+ xs -> Just (intercalate ", " xs)+++doPropFind ::+ RowNameMode ->+ String ->+ [String] ->+ Maybe Text ->+ Maybe Text ->+ Element ->+ Handler+ (Headers '[Header "Preference-Applied" String] [PropResults])+doPropFind mode dbPath urlPath depth preferMb doc = do+ let+ urlPathNorm = urlPath & filter (/= "")+ propNames =+ [ qName $ elName x+ | Elem x <- concatMap elContent ([x | Elem x <- elContent doc])+ ]+ prefs = parsePrefer preferMb++ results <- case urlPathNorm of+ [] -> do+ let itemType = Folder++ itemProps <-+ propNames+ & mapM (propNameToEntry mode dbPath urlPathNorm itemType)+ <&> catMaybes++ let+ rootPropResult =+ PropResults+ { propName = ""+ , itemType+ , props = itemProps+ , propMissing = propNames & keepMissingNames itemType+ }+ depthLow = depth <&> toLower++ (tableRows :: [[Text]]) <-+ liftIO $ withConnection dbPath $ \conn ->+ query_ conn "SELECT name FROM sqlite_master WHERE type == 'table'"++ folderProps <-+ propNames+ & mapM (propNameToEntry mode dbPath urlPathNorm Folder)+ <&> catMaybes++ pure $+ rootPropResult+ : if depthLow /= Just "1" && depthLow /= Just "infinity"+ then []+ else+ tableRows+ & concat+ <&> \table ->+ PropResults+ { propName = T.unpack table+ , itemType = Folder+ , props = folderProps+ , propMissing = propNames & keepMissingNames Folder+ }+ --+ tableName : restPath -> do+ isSqlar <- liftIO $ SQLAR.isSqlarTable dbPath (T.pack tableName)+ if isSqlar+ then getPropsForSqlar dbPath depth propNames tableName restPath+ else case restPath of+ [] ->+ getPropsForTable mode dbPath urlPathNorm depth propNames tableName+ [rowName] -> do+ rowidMb <-+ liftIO $ resolveRowid mode dbPath (T.pack tableName) rowName+ getPropsForRow+ mode+ dbPath+ urlPathNorm+ depth+ propNames+ tableName+ rowidMb+ rowName : colNameWithExt : _rest -> do+ rowidMb <-+ liftIO $ resolveRowid mode dbPath (T.pack tableName) rowName+ getPropsForCell+ mode+ dbPath+ urlPathNorm+ propNames+ tableName+ rowidMb+ colNameWithExt++ let (appliedPrefs, filtered) = applyPreferences prefs depth results+ pure $ case preferenceAppliedHeader appliedPrefs of+ Nothing -> noHeader filtered+ Just hdr -> addHeader hdr filtered+++-- | Escape double quotes in SQL strings+escDoubleQuotes :: Text -> Text+escDoubleQuotes =+ T.replace "\"" "\"\""+++-- | Quote a keyword in an SQL query+quoteKeyword :: Text -> Text+quoteKeyword keyword =+ keyword+ & escDoubleQuotes+ & (\word -> "\"" <> word <> "\"")+++-- Plain-table helpers --------------------------------------------------------+-- These power the non-sqlar WebDAV code paths.++{-| The single-column primary key of @tableName@, if exactly one such+column exists. Returns 'Nothing' for tables with no PK or with a+composite PK; callers fall back to rowid-based naming in those+cases so the URL stays unambiguous.+-}+singlePkColumn :: FilePath -> Text -> IO (Maybe Text)+singlePkColumn dbPath tableName =+ withConnection dbPath $ \conn -> do+ rows :: [Only Text] <-+ query+ conn+ "SELECT name FROM pragma_table_info(?) WHERE pk > 0 ORDER BY pk"+ (Only tableName)+ pure $ case rows of+ [Only c] -> Just c+ _ -> Nothing+++-- | Render a SQLData value as the URL-segment representation of a PK.+pkValueText :: SQLData -> Text+pkValueText sqlData = case sqlData of+ SQLText t -> t+ SQLInteger i -> show i+ SQLFloat f -> show f+ SQLBlob _ -> ""+ SQLNull -> ""+++-- | Read the PK column value for a given rowid.+lookupPkValue ::+ FilePath ->+ Text ->+ Text ->+ Integer ->+ IO (Maybe Text)+lookupPkValue dbPath tableName pkCol rowid =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "SELECT "+ <> quoteKeyword pkCol+ <> " FROM "+ <> quoteKeyword tableName+ <> " WHERE rowid = ? LIMIT 1"+ rows :: [Only SQLData] <- query conn q (Only rowid)+ pure $ case rows of+ [Only v] -> Just (pkValueText v)+ _ -> Nothing+++-- | Find the rowid of the row whose PK column equals @pkValue@.+findRowidByPk ::+ FilePath ->+ Text ->+ Text ->+ Text ->+ IO (Maybe Integer)+findRowidByPk dbPath tableName pkCol pkValue =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "SELECT rowid FROM "+ <> quoteKeyword tableName+ <> " WHERE "+ <> quoteKeyword pkCol+ <> " = ? LIMIT 1"+ rows :: [Only Integer] <- query conn q (Only pkValue)+ pure $ case rows of+ [Only r] -> Just r+ _ -> Nothing+++{-| Format a URL segment that names a specific row. Falls back to the+plain rowid when the table has no single-column PK or when the+rowid is missing from the table, so unrelated tables stay routable.+-}+formatRowSegment ::+ RowNameMode ->+ FilePath ->+ Text ->+ Integer ->+ IO String+formatRowSegment mode dbPath tableName rowid =+ case mode of+ RowIdMode -> pure (show rowid)+ PrimaryKeyMode -> do+ pkMb <- singlePkColumn dbPath tableName+ case pkMb of+ Nothing -> pure (show rowid)+ Just pkCol -> do+ valMb <- lookupPkValue dbPath tableName pkCol rowid+ pure $ case valMb of+ Just v | not (T.null v) -> T.unpack v+ _ -> show rowid+ CombinedMode -> do+ pkMb <- singlePkColumn dbPath tableName+ case pkMb of+ Nothing -> pure (show rowid)+ Just pkCol -> do+ valMb <- lookupPkValue dbPath tableName pkCol rowid+ pure $ case valMb of+ Just v+ | not (T.null v) ->+ show rowid <> " - " <> T.unpack v+ _ -> show rowid+++{-| Resolve a URL row segment to an integer rowid. Handles all three+naming modes:++ * @RowIdMode@ — the segment is parsed as an integer.+ * @CombinedMode@ — the rowid is parsed from the prefix preceding+ @" - "@. The trailing PK value is ignored, since the rowid is+ already enough to identify the row.+ * @PrimaryKeyMode@ — the table's PK column is queried for a row+ whose PK value matches the segment. Tables without a single-column+ PK fall back to integer parsing so they remain reachable.+-}+resolveRowid ::+ RowNameMode ->+ FilePath ->+ Text ->+ String ->+ IO (Maybe Integer)+resolveRowid mode dbPath tableName seg =+ case mode of+ RowIdMode -> pure (readMaybe seg)+ CombinedMode ->+ let+ segTxt = T.pack seg+ (pref, rest) = T.breakOn " - " segTxt+ rowidPart =+ if T.null rest+ then segTxt+ else pref+ in+ pure (readMaybe (T.unpack rowidPart))+ PrimaryKeyMode -> do+ pkMb <- singlePkColumn dbPath tableName+ case pkMb of+ Nothing -> pure (readMaybe seg)+ Just pkCol -> findRowidByPk dbPath tableName pkCol (T.pack seg)+++tableExists :: FilePath -> Text -> IO Bool+tableExists dbPath name =+ withConnection dbPath $ \conn -> do+ rows :: [Only Int] <-+ query+ conn+ "SELECT 1 FROM sqlite_master WHERE type = 'table' AND name = ? LIMIT 1"+ (Only name)+ pure $ not (null rows)+++listColumnNames :: FilePath -> Text -> IO [Text]+listColumnNames dbPath name =+ withConnection dbPath $ \conn -> do+ cols :: [Only Text] <-+ query+ conn+ "SELECT name FROM pragma_table_info(?)"+ (Only name)+ pure $ fmap (\(Only n) -> n) cols+++columnExists :: FilePath -> Text -> Text -> IO Bool+columnExists dbPath tableName colName = do+ cols <- listColumnNames dbPath tableName+ pure (colName `elem` cols)+++{-| Declared type of a column, as reported by @pragma_table_info@.+Returns Nothing when the column doesn't exist or the table is+malformed.+-}+lookupColumnType :: FilePath -> Text -> Text -> IO (Maybe Text)+lookupColumnType dbPath tableName colName =+ withConnection dbPath $ \conn -> do+ rows :: [Only Text] <-+ query+ conn+ "SELECT type FROM pragma_table_info(?) WHERE name = ?"+ (tableName, colName)+ pure $ case rows of+ [Only t] -> Just t+ _ -> Nothing+++-- | SQLite type affinity (https://sqlite.org/datatype3.html §3.1).+data ColumnAffinity+ = AffinityInteger+ | AffinityText+ | AffinityBlob+ | AffinityReal+ | AffinityNumeric+ deriving (Show, Eq)+++-- | Derive SQLite's affinity from a declared column type.+affinityFromDeclared :: Text -> ColumnAffinity+affinityFromDeclared declared+ | "INT" `T.isInfixOf` upper = AffinityInteger+ | "CHAR" `T.isInfixOf` upper+ || "CLOB" `T.isInfixOf` upper+ || "TEXT" `T.isInfixOf` upper =+ AffinityText+ | "BLOB" `T.isInfixOf` upper || T.null upper = AffinityBlob+ | "REAL" `T.isInfixOf` upper+ || "FLOA" `T.isInfixOf` upper+ || "DOUB" `T.isInfixOf` upper =+ AffinityReal+ | otherwise = AffinityNumeric+ where+ upper = T.toUpper declared+++{-| Interpret a PUT body for a plain cell, honoring the column's+affinity so a TEXT/INTEGER/REAL cell doesn't end up storing a+BLOB. Invalid UTF-8 always falls back to SQLBlob; an unparsable+number on an INTEGER/REAL column falls back to SQLText so the+user's data isn't silently turned into a binary blob.+-}+coerceBody :: ColumnAffinity -> ByteString -> SQLData+coerceBody affinity body =+ case (affinity, T.decodeUtf8' body) of+ (AffinityBlob, _) -> SQLBlob body+ (_, Left _) -> SQLBlob body+ (AffinityText, Right txt) -> SQLText txt+ (AffinityInteger, Right txt) -> tryInt txt+ (AffinityReal, Right txt) -> tryReal txt+ (AffinityNumeric, Right txt) -> case readMaybeStripped txt of+ Just (n :: Integer) -> SQLInteger (fromInteger n)+ Nothing -> tryReal txt+ where+ readMaybeStripped t = readMaybe (T.unpack (T.strip t))+ tryInt t = case readMaybeStripped t of+ Just (n :: Integer) -> SQLInteger (fromInteger n)+ Nothing -> SQLText t+ tryReal t = case readMaybeStripped t of+ Just (x :: Double) -> SQLFloat x+ Nothing -> SQLText t+++rowExists :: FilePath -> Text -> Integer -> IO Bool+rowExists dbPath tableName rowid =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "SELECT 1 FROM "+ <> quoteKeyword tableName+ <> " WHERE rowid = ? LIMIT 1"+ rows :: [Only Int] <- query conn q (Only rowid)+ pure $ not (null rows)+++{-| True when the cell at (table, rowid, col) is currently NULL.+Used to choose between 201 (new content) and 204 (overwrite) on PUT.+-}+cellIsNull :: FilePath -> Text -> Integer -> Text -> IO Bool+cellIsNull dbPath tableName rowid colName =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "SELECT "+ <> quoteKeyword colName+ <> " FROM "+ <> quoteKeyword tableName+ <> " WHERE rowid = ? LIMIT 1"+ rows :: [Only SQLData] <- query conn q (Only rowid)+ pure $ case rows of+ [Only SQLNull] -> True+ _ -> False+++-- | Read a single cell value (Nothing when the row/column does not exist).+readCell ::+ FilePath ->+ Text ->+ Integer ->+ Text ->+ IO (Maybe SQLData)+readCell dbPath tableName rowid colName =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "SELECT "+ <> quoteKeyword colName+ <> " FROM "+ <> quoteKeyword tableName+ <> " WHERE rowid = ? LIMIT 1"+ rows :: [Only SQLData] <- query conn q (Only rowid)+ pure $ case rows of+ [Only v] -> Just v+ _ -> Nothing+++updateCell ::+ FilePath ->+ Text ->+ Integer ->+ Text ->+ SQLData ->+ IO ()+updateCell dbPath tableName rowid colName value =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "UPDATE "+ <> quoteKeyword tableName+ <> " SET "+ <> quoteKeyword colName+ <> " = ? WHERE rowid = ?"+ execute conn q (value, rowid)+++dropTable :: FilePath -> Text -> IO ()+dropTable dbPath tableName =+ withConnection dbPath $ \conn -> do+ let q = Query $ "DROP TABLE " <> quoteKeyword tableName+ execute conn q ()+++deleteRow :: FilePath -> Text -> Integer -> IO ()+deleteRow dbPath tableName rowid =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "DELETE FROM "+ <> quoteKeyword tableName+ <> " WHERE rowid = ?"+ execute conn q (Only rowid)+++{-| Create a new table with the sqlar schema. This makes the new+collection immediately usable as a WebDAV folder via the sqlar code+path — clients can MKCOL/PUT/COPY/MOVE under it without first+defining a custom schema.+-}+createSqlarTable :: FilePath -> Text -> IO ()+createSqlarTable dbPath tableName =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "CREATE TABLE "+ <> quoteKeyword tableName+ <> " ("+ <> "name TEXT PRIMARY KEY,"+ <> "mode INT,"+ <> "mtime INT,"+ <> "sz INT,"+ <> "data BLOB"+ <> ")"+ execute conn q ()+++{-| Insert a row at the requested rowid with all other columns set to+NULL. Returns False (without raising) if a NOT NULL constraint+without a default value prevents the insert; the caller maps that+to 409 Conflict.+-}+insertEmptyRow :: FilePath -> Text -> Integer -> IO Bool+insertEmptyRow dbPath tableName rowid =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "INSERT INTO "+ <> quoteKeyword tableName+ <> " (rowid) VALUES (?)"+ catchAll+ (do execute conn q (Only rowid); pure True)+ (\_ -> pure False)+++{-| Insert a row whose primary-key column is set to @pkValue@ (all+other columns NULL). Mirrors 'insertEmptyRow' but keyed by an+arbitrary PK column so PK-mode MKCOL can create rows reachable by+the same URL segment that names them.+-}+insertRowByPk :: FilePath -> Text -> Text -> Text -> IO Bool+insertRowByPk dbPath tableName pkCol pkValue =+ withConnection dbPath $ \conn -> do+ let q =+ Query $+ "INSERT INTO "+ <> quoteKeyword tableName+ <> " ("+ <> quoteKeyword pkCol+ <> ") VALUES (?)"+ catchAll+ (do execute conn q (Only pkValue); pure True)+ (\_ -> pure False)+++-- | Clone every column from @srcRowid@ to @dstRowid@ (replacing dst).+cloneRow :: FilePath -> Text -> Integer -> Integer -> IO ()+cloneRow dbPath tableName srcRowid dstRowid =+ withConnection dbPath $ \conn -> do+ cols :: [Only Text] <-+ query+ conn+ "SELECT name FROM pragma_table_info(?)"+ (Only tableName)+ let colNames = fmap (\(Only n) -> n) cols+ quoted = T.intercalate "," (fmap quoteKeyword colNames)+ -- INSERT OR REPLACE so an existing dst row is overwritten.+ insertQ =+ Query $+ "INSERT OR REPLACE INTO "+ <> quoteKeyword tableName+ <> " (rowid,"+ <> quoted+ <> ") SELECT ?, "+ <> quoted+ <> " FROM "+ <> quoteKeyword tableName+ <> " WHERE rowid = ?"+ execute conn insertQ (dstRowid, srcRowid)
+ src/SQLiteDAV/Utils.hs view
@@ -0,0 +1,35 @@+module SQLiteDAV.Utils where++import Protolude (Maybe (Just), Text, show, ($), (&))++import Data.ByteString.Lazy.Char8 qualified as Lazy.Char8+import Data.Text qualified as T+import Data.Time (FormatTime, defaultTimeLocale, formatTime)+import Database.SQLite.Simple (SQLData (..))+++sqlDataToText :: SQLData -> Text+sqlDataToText sqlData =+ case sqlData of+ SQLText text -> text+ SQLInteger int -> T.pack $ show int+ SQLFloat float -> T.pack $ show float+ SQLBlob blob -> T.pack $ show blob+ SQLNull -> "NULL"+++sqlDataToFileContent :: SQLData -> Lazy.Char8.ByteString+sqlDataToFileContent sqlData =+ case sqlData of+ SQLText text -> Lazy.Char8.pack $ T.unpack text+ SQLInteger int -> show int+ SQLFloat float -> show float+ SQLBlob blob -> Lazy.Char8.fromStrict blob+ SQLNull -> "NULL"+++formatTimestamp :: (FormatTime t) => t -> Text+formatTimestamp timestamp =+ timestamp+ & formatTime defaultTimeLocale "%a, %e %b %Y %H:%M:%S %Z"+ & T.pack
+ test/Spec.hs view
@@ -0,0 +1,1696 @@+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++module Spec where++import Protolude (+ Char,+ IO,+ Int,+ Integer,+ Maybe (..),+ Text,+ decodeUtf8,+ fmap,+ for_,+ isSpace,+ liftIO,+ not,+ panic,+ pure,+ show,+ traceShowId,+ unless,+ ($),+ (&),+ (*),+ (.),+ (<&>),+ (<>),+ (==),+ )+import Protolude.Unsafe (unsafeIndex)++import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.String (fromString)+import Data.Text qualified as T+import Data.Time (getCurrentTime)+import Database.SQLite.Simple (+ Only (Only),+ SQLData (SQLBlob),+ execute,+ execute_,+ query,+ withConnection,+ )+import Debug.Trace (traceM)+import Network.HTTP.Types (hContentType)+import Network.Wai ()+import Network.Wai.Test (SResponse (..), simpleBody)+import System.Directory (copyFile, doesFileExist, removeFile)+import Test.Hspec (Spec, describe, fit, hspec, it)+import Test.Hspec.Wai (+ MatchHeader,+ ResponseMatcher (+ ResponseMatcher,+ matchBody,+ matchHeaders,+ matchStatus+ ),+ WaiSession,+ delete,+ get,+ options,+ request,+ shouldRespondWith,+ with,+ (<:>),+ )+import Text.Regex.TDFA++import SQLiteDAV.API ()+import SQLiteDAV.HTTPExtensions ()+import SQLiteDAV.Properties ()+import SQLiteDAV.Server (RowNameMode (..), webDavServer)+import SQLiteDAV.Utils (formatTimestamp)+++type String = [Char]+++{-| Perform an `PROPFIND` request to the application under test.+| FIXME: Can't reference Data.ByteString.Internal.ByteString here,+| because it can not be imported.+-}+propfind :: _ -> Integer -> _ -> WaiSession st SResponse+propfind path depth =+ request+ "PROPFIND"+ path+ [ (hContentType, "application/xml")+ , ("Depth", show depth)+ ]+++propfindPrefer :: _ -> Integer -> _ -> _ -> WaiSession st SResponse+propfindPrefer path depth prefer =+ request+ "PROPFIND"+ path+ [ (hContentType, "application/xml")+ , ("Depth", show depth)+ , ("Prefer", prefer)+ ]+++lock :: _ -> _ -> WaiSession st SResponse+lock path =+ request+ "LOCK"+ path+ [(hContentType, "application/xml")]+++unlock :: _ -> _ -> WaiSession st SResponse+unlock path token =+ request+ "UNLOCK"+ path+ [("Lock-Token", token)]+ ""+++-- | Remove leading whitespace on each line of a string+rmLeadSpace :: Text -> Text+rmLeadSpace = T.unlines . fmap (T.dropWhile isSpace) . T.lines+++-- | Recursively remove all spaces between tags+rmXmlSpace :: T.Text -> T.Text+rmXmlSpace xmlTxt =+ let+ xmlEnd = T.replace "> " ">" xmlTxt+ xmlNorm = T.replace " <" "<" xmlEnd+ in+ if xmlNorm == xmlTxt+ then xmlNorm+ else rmXmlSpace xmlNorm+++normalizeXml :: Text -> Text+normalizeXml xmlRequest =+ rmXmlSpace $+ "<?xml version='1.0' ?>"+ <> ( xmlRequest+ & T.replace "</" "</D:"+ & T.replace "<" "<D:"+ & T.replace "<D:/D:" "</D:"+ )+++davHeader :: MatchHeader+davHeader = "Dav" <:> "1, 2, ordered-collections"+++xmlHeader :: MatchHeader+xmlHeader = "Content-Type" <:> "application/xml"+++rmModified :: WaiSession st SResponse -> WaiSession st SResponse+rmModified fRes =+ let+ regex :: BL.ByteString = "<D:getlastmodified>([^<>]+)</D:getlastmodified>"+ in+ fRes+ <&> ( \sres ->+ let+ bodyTxt :: Text =+ sres+ & simpleBody+ & BL.toStrict+ & decodeUtf8+ timestampMatch :: Text =+ bodyTxt =~ regex+ simpleBodyNew =+ bodyTxt+ & T.replace+ timestampMatch+ "<D:getlastmodified>REMOVED</D:getlastmodified>"+ & T.unpack+ & fromString+ in+ sres{simpleBody = simpleBodyNew}+ )+++{-| Copy the test fixture database to a scratch path so tests can mutate it+without polluting the committed file.+-}+mkTestApp :: IO _+mkTestApp = do+ let scratchDb = "test/data_scratch.sqlite"+ copyFile "test/data.sqlite" scratchDb+ pure $ webDavServer RowIdMode scratchDb+++-- | Same as 'mkTestApp' but for the sqlar fixture.+mkSqlarApp :: IO _+mkSqlarApp = do+ let scratchDb = "test/archive_scratch.sqlar"+ copyFile "test/archive.sqlar" scratchDb+ pure $ webDavServer RowIdMode scratchDb+++{-| Build a fixture with a single table whose payloads are large enough+that loading them all into memory (as the pre-fix server did) would+inflate the listing cost by several megabytes per row. Used to guard+against regressions of issue #14.+-}+mkBigBlobApp :: IO _+mkBigBlobApp = do+ let scratchDb = "test/big_blobs_scratch.sqlite"+ exists <- doesFileExist scratchDb+ unless (not exists) $ removeFile scratchDb+ withConnection scratchDb $ \conn -> do+ execute_ conn "CREATE TABLE big_blobs (payload BLOB)"+ let blob = SQLBlob (BS.replicate (256 * 1024) 0x42)+ for_ [1 :: Int .. 32] $ \_ ->+ execute conn "INSERT INTO big_blobs (payload) VALUES (?)" [blob]+ pure $ webDavServer RowIdMode scratchDb+++put :: _ -> _ -> WaiSession st SResponse+put path =+ request+ "PUT"+ path+ [(hContentType, "application/octet-stream")]+++{-| Report @typeof(col)@ for a given users row in the scratch fixture.+Used by the PUT type-preservation tests.+-}+typeofCell :: Text -> Int -> IO Text+typeofCell colName rowid =+ withConnection "test/data_scratch.sqlite" $ \conn -> do+ let q = fromString ("SELECT typeof(" <> T.unpack colName <> ") FROM users WHERE rowid = ?")+ rows :: [Only Text] <- query conn q (Only rowid)+ pure $ case rows of+ [Only t] -> t+ _ -> "missing"+++mkcol :: _ -> WaiSession st SResponse+mkcol path =+ request+ "MKCOL"+ path+ []+ ""+++spec :: Spec+spec = with mkTestApp $ do+ describe "OPTIONS" $ do+ it "returns 200 for OPTIONS requests" $ do+ options "/" `shouldRespondWith` 200+ describe "PROPFIND" $ do+ it "returns a list of PropResults" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <getlastmodified/>\+ \ <getcontentlength/>\+ \ <creationdate/>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"++ result = propfind "/" 0 (fromString (T.unpack xmlRequest))++ rmModified result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders = [davHeader, xmlHeader]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "returns a list of PropResults for tables" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <getlastmodified/>\+ \ <getcontentlength/>\+ \ <creationdate/>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/users</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"+ result = propfind "/users" 0 (fromString (T.unpack xmlRequest))++ rmModified result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders = [davHeader, xmlHeader]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "returns a list of PropResults for table rows" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <getlastmodified/>\+ \ <getcontentlength/>\+ \ <creationdate/>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/users</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/1</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/2</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/3</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"+ result = propfind "/users/" 1 (fromString (T.unpack xmlRequest))++ rmModified result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders = [davHeader, xmlHeader]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "returns a list of PropResults for table columns" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <getlastmodified/>\+ \ <getcontentlength/>\+ \ <creationdate/>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/users/1</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/1/name.txt</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ <getcontentlength>4</getcontentlength>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/1/email.txt</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ <getcontentlength>16</getcontentlength>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/1/height.txt</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ <getcontentlength>3</getcontentlength>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/1/photo.png</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ <getcontentlength>135872</getcontentlength>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <creationdate />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"++ let result = propfind "/users/1" 1 (fromString (T.unpack xmlRequest))+ rmModified result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders = [davHeader, xmlHeader]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ let resSlash = propfind "/users/1/" 1 (fromString (T.unpack xmlRequest))+ rmModified resSlash+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders = [davHeader, xmlHeader]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "Prefer: depth-noroot omits the root resource" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <getlastmodified/>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/users/1</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/2</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/3</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"+ result =+ propfindPrefer+ "/users/"+ 1+ "depth-noroot"+ (fromString (T.unpack xmlRequest))++ rmModified result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders =+ [ davHeader+ , xmlHeader+ , "Preference-Applied" <:> "depth-noroot"+ ]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "Prefer: depth-noroot is ignored when Depth is 0" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <getlastmodified/>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/users</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"+ result =+ propfindPrefer+ "/users"+ 0+ "depth-noroot"+ (fromString (T.unpack xmlRequest))++ rmModified result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders = [davHeader, xmlHeader]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "Prefer: return=minimal omits 404 propstat blocks" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <getlastmodified/>\+ \ <getcontentlength/>\+ \ <creationdate/>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/users</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"+ result =+ propfindPrefer+ "/users"+ 0+ "return=minimal"+ (fromString (T.unpack xmlRequest))++ rmModified result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders =+ [ davHeader+ , xmlHeader+ , "Preference-Applied" <:> "return=minimal"+ ]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "returns 400 for malformed XML body" $ do+ request+ "PROPFIND"+ "/"+ [(hContentType, "application/xml"), ("Depth", "0")]+ "<foo>"+ `shouldRespondWith` 400++ it "returns 400 when a prefix is bound to the empty namespace" $ do+ request+ "PROPFIND"+ "/"+ [(hContentType, "application/xml"), ("Depth", "0")]+ ( "<D:propfind xmlns:D=\"DAV:\">"+ <> "<D:prop><bar:foo xmlns:bar=\"\"/></D:prop>"+ <> "</D:propfind>"+ )+ `shouldRespondWith` 400++ it "Prefer can combine depth-noroot and return=minimal" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <getlastmodified/>\+ \ <creationdate/>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/users/1</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/2</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/users/3</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ <getlastmodified>REMOVED</getlastmodified>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"+ result =+ propfindPrefer+ "/users/"+ 1+ "depth-noroot, return=minimal"+ (fromString (T.unpack xmlRequest))++ rmModified result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders =+ [ davHeader+ , xmlHeader+ , "Preference-Applied" <:> "depth-noroot, return=minimal"+ ]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ describe "GET" $ do+ it "returns the content of a cell" $ do+ get "/users/1/name"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "John"+ }++ describe "DELETE" $ do+ it "sets a cell to NULL" $ do+ delete "/users/2/email"+ `shouldRespondWith` 204+ get "/users/2/email"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "NULL"+ }++ describe "LOCK" $ do+ it "returns a fake lock token and lockdiscovery XML" $ do+ let+ xmlRequest =+ normalizeXml+ "<lockinfo xmlns:D=\"DAV:\">\+ \ <lockscope><exclusive/></lockscope>\+ \ <locktype><write/></locktype>\+ \ <owner>\+ \ <href>http://example.com/owner</href>\+ \ </owner>\+ \</lockinfo>\+ \"+ xmlResponse =+ normalizeXml+ "<prop xmlns:D=\"DAV:\">\+ \ <lockdiscovery>\+ \ <activelock>\+ \ <locktype><write /></locktype>\+ \ <lockscope><exclusive /></lockscope>\+ \ <depth>infinity</depth>\+ \ <timeout>Second-604800</timeout>\+ \ <locktoken>\+ \ <href>urn:uuid:00000000-0000-0000-0000-000000000001</href>\+ \ </locktoken>\+ \ <lockroot>\+ \ <href>/users/1/name.txt</href>\+ \ </lockroot>\+ \ </activelock>\+ \ </lockdiscovery>\+ \</prop>\+ \"+ result = lock "/users/1/name.txt" (fromString (T.unpack xmlRequest))++ result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders =+ [ davHeader+ , xmlHeader+ , "Lock-Token"+ <:> "<urn:uuid:00000000-0000-0000-0000-000000000001>"+ ]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ describe "UNLOCK" $ do+ it "returns 204 No Content" $ do+ unlock+ "/users/1/name.txt"+ "<urn:uuid:00000000-0000-0000-0000-000000000001>"+ `shouldRespondWith` 204+++sqlarSpec :: Spec+sqlarSpec = with mkSqlarApp $ do+ describe "SQLAR archive" $ do+ describe "PROPFIND" $ do+ it "lists top-level entries with Depth 1" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <resourcetype/>\+ \ <getcontentlength/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/sqlar</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/sqlar/docs</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/sqlar/readme.txt</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <getcontentlength>11</getcontentlength>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"++ result = propfind "/sqlar/" 1 (fromString (T.unpack xmlRequest))++ result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders = [davHeader, xmlHeader]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "lists a nested folder" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <resourcetype/>\+ \ <getcontentlength/>\+ \ </prop>\+ \</propfind>\+ \"+ xmlResponse =+ normalizeXml+ "<multistatus xmlns:D=\"DAV:\">\+ \ <response>\+ \ <href>/sqlar/docs</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/sqlar/docs/guide</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <resourcetype>\+ \ <collection />\+ \ </resourcetype>\+ \ </prop>\+ \ </propstat>\+ \ <propstat>\+ \ <status>HTTP/1.1 404 Not Found</status>\+ \ <prop>\+ \ <getcontentlength />\+ \ </prop>\+ \ <responsedescription>\+ \ Property was not found\+ \ </responsedescription>\+ \ </propstat>\+ \ </response>\+ \ <response>\+ \ <href>/sqlar/docs/intro.md</href>\+ \ <propstat>\+ \ <status>HTTP/1.1 200 OK</status>\+ \ <prop>\+ \ <getcontentlength>8</getcontentlength>\+ \ </prop>\+ \ </propstat>\+ \ </response>\+ \</multistatus>\+ \"++ result = propfind "/sqlar/docs" 1 (fromString (T.unpack xmlRequest))++ result+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 207+ , matchHeaders = [davHeader, xmlHeader]+ , matchBody = fromString (T.unpack xmlResponse)+ }++ it "returns 404 for missing archive paths" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop><resourcetype/></prop>\+ \</propfind>\+ \"+ result =+ propfind "/sqlar/missing" 0 (fromString (T.unpack xmlRequest))++ result `shouldRespondWith` 404++ describe "GET" $ do+ it "returns file content from the archive" $ do+ get "/sqlar/readme.txt"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "hello world"+ }++ it "returns nested file content from the archive" $ do+ get "/sqlar/docs/guide/setup.md"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "# Setup\n"+ }++ it "returns 404 for missing files" $ do+ get "/sqlar/missing.txt" `shouldRespondWith` 404++ describe "PUT" $ do+ it "stores a new file in the archive" $ do+ put "/sqlar/new.txt" "fresh content"+ `shouldRespondWith` 201+ get "/sqlar/new.txt"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "fresh content"+ }++ it "replaces an existing file" $ do+ put "/sqlar/readme.txt" "updated"+ `shouldRespondWith` 201+ get "/sqlar/readme.txt"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "updated"+ }++ it "rejects PUT when the parent collection is missing" $ do+ put "/sqlar/missing-dir/file.txt" "x" `shouldRespondWith` 409++ it "rejects PUT onto a folder path" $ do+ put "/sqlar/docs" "stuff" `shouldRespondWith` 405++ describe "DELETE" $ do+ it "removes a file from the archive" $ do+ delete "/sqlar/readme.txt" `shouldRespondWith` 204+ get "/sqlar/readme.txt" `shouldRespondWith` 404++ it "removes a folder subtree" $ do+ delete "/sqlar/docs" `shouldRespondWith` 204+ get "/sqlar/docs/intro.md" `shouldRespondWith` 404+ get "/sqlar/docs/guide/setup.md" `shouldRespondWith` 404++ it "returns 404 when the target does not exist" $ do+ delete "/sqlar/nope.txt" `shouldRespondWith` 404++ describe "MKCOL" $ do+ it "creates a folder entry" $ do+ mkcol "/sqlar/empty-dir" `shouldRespondWith` 201+ -- After creation, a child can be PUT into it+ put "/sqlar/empty-dir/x.txt" "x" `shouldRespondWith` 201+ get "/sqlar/empty-dir/x.txt"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "x"+ }++ it "rejects MKCOL on an existing collection" $ do+ mkcol "/sqlar/docs" `shouldRespondWith` 405++ it "rejects MKCOL on an existing file" $ do+ mkcol "/sqlar/readme.txt" `shouldRespondWith` 405++ it "rejects MKCOL when the parent is missing" $ do+ mkcol "/sqlar/missing/sub" `shouldRespondWith` 409++ it "rejects MKCOL carrying a body" $ do+ request "MKCOL" "/sqlar/with-body" [("Content-Length", "4")] "junk"+ `shouldRespondWith` 415++ describe "COPY" $ do+ it "copies a single file" $ do+ request+ "COPY"+ "/sqlar/readme.txt"+ [("Destination", "/sqlar/readme-copy.txt")]+ ""+ `shouldRespondWith` 201+ get "/sqlar/readme-copy.txt"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "hello world"+ }+ -- Source still exists after a COPY+ get "/sqlar/readme.txt" `shouldRespondWith` 200++ it "copies a subtree" $ do+ request+ "COPY"+ "/sqlar/docs"+ [("Destination", "/sqlar/docs-copy")]+ ""+ `shouldRespondWith` 201+ get "/sqlar/docs-copy/intro.md"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "# Intro\n"+ }+ get "/sqlar/docs-copy/guide/setup.md"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "# Setup\n"+ }++ it "returns 204 when overwriting an existing destination" $ do+ request+ "COPY"+ "/sqlar/readme.txt"+ [("Destination", "/sqlar/docs/intro.md")]+ ""+ `shouldRespondWith` 204+ get "/sqlar/docs/intro.md"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "hello world"+ }++ it "returns 412 when destination exists and Overwrite: F" $ do+ request+ "COPY"+ "/sqlar/readme.txt"+ [ ("Destination", "/sqlar/docs/intro.md")+ , ("Overwrite", "F")+ ]+ ""+ `shouldRespondWith` 412++ it "returns 409 when destination parent is missing" $ do+ request+ "COPY"+ "/sqlar/readme.txt"+ [("Destination", "/sqlar/nowhere/dest.txt")]+ ""+ `shouldRespondWith` 409++ it "returns 404 when source does not exist" $ do+ request+ "COPY"+ "/sqlar/missing.txt"+ [("Destination", "/sqlar/dest.txt")]+ ""+ `shouldRespondWith` 404++ describe "MOVE" $ do+ it "moves a single file" $ do+ request+ "MOVE"+ "/sqlar/readme.txt"+ [("Destination", "/sqlar/moved.txt")]+ ""+ `shouldRespondWith` 201+ get "/sqlar/moved.txt"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "hello world"+ }+ -- Source is gone after a MOVE+ get "/sqlar/readme.txt" `shouldRespondWith` 404++ it "moves a subtree" $ do+ request+ "MOVE"+ "/sqlar/docs"+ [("Destination", "/sqlar/docs-moved")]+ ""+ `shouldRespondWith` 201+ get "/sqlar/docs-moved/guide/setup.md"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "# Setup\n"+ }+ get "/sqlar/docs/intro.md" `shouldRespondWith` 404++ it "returns 204 when overwriting an existing destination" $ do+ put "/sqlar/dest.txt" "old" `shouldRespondWith` 201+ request+ "MOVE"+ "/sqlar/readme.txt"+ [("Destination", "/sqlar/dest.txt")]+ ""+ `shouldRespondWith` 204+ get "/sqlar/dest.txt"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "hello world"+ }+++plainSpec :: Spec+plainSpec = with mkTestApp $ do+ describe "Plain SQLite mode" $ do+ describe "PUT" $ do+ it "updates an existing cell and reports 204" $ do+ put "/users/1/name.txt" "Updated"+ `shouldRespondWith` 204+ get "/users/1/name"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "Updated"+ }++ it "returns 201 when filling a previously NULL cell" $ do+ delete "/users/2/email" `shouldRespondWith` 204+ put "/users/2/email.txt" "ada@example.com"+ `shouldRespondWith` 201++ it "returns 404 for an unknown column" $ do+ put "/users/1/nonsense.txt" "x" `shouldRespondWith` 404++ it "returns 409 for a missing row" $ do+ put "/users/999/name.txt" "x" `shouldRespondWith` 409++ it "returns 404 for an unknown table" $ do+ put "/no_such_table/1/name.txt" "x" `shouldRespondWith` 404++ it "returns 405 when targeting a row instead of a cell" $ do+ put "/users/1" "x" `shouldRespondWith` 405++ it "keeps the TEXT column's storage type after a PUT" $ do+ put "/users/1/name.txt" "Renamed" `shouldRespondWith` 204+ cellType <- liftIO $ typeofCell "name" 1+ liftIO $ unless (cellType == "text") $+ panic ("Expected 'text', got: " <> cellType)++ it "keeps the INTEGER column's storage type after a PUT" $ do+ put "/users/1/height.txt" "200" `shouldRespondWith` 204+ cellType <- liftIO $ typeofCell "height" 1+ liftIO $ unless (cellType == "integer") $+ panic ("Expected 'integer', got: " <> cellType)++ it "falls back to text for an unparsable INTEGER body" $ do+ put "/users/1/height.txt" "tall" `shouldRespondWith` 204+ cellType <- liftIO $ typeofCell "height" 1+ liftIO $ unless (cellType == "text") $+ panic ("Expected 'text', got: " <> cellType)++ it "keeps the BLOB column's storage type after a PUT" $ do+ put "/users/1/photo.png" "\xff\xd8\xff" `shouldRespondWith` 204+ cellType <- liftIO $ typeofCell "photo" 1+ liftIO $ unless (cellType == "blob") $+ panic ("Expected 'blob', got: " <> cellType)++ describe "DELETE" $ do+ it "404s on a missing cell column" $ do+ delete "/users/1/nonsense" `shouldRespondWith` 404++ it "404s on a missing row" $ do+ delete "/users/999" `shouldRespondWith` 404++ it "deletes a row" $ do+ delete "/users/3" `shouldRespondWith` 204+ get "/users/3/name" `shouldRespondWith` 404++ it "drops a table" $ do+ delete "/users" `shouldRespondWith` 204+ get "/users/1/name" `shouldRespondWith` 404++ it "refuses to delete the database root" $ do+ delete "/" `shouldRespondWith` 403++ describe "MKCOL" $ do+ it "creates a new (sqlar-shaped) table at the root" $ do+ mkcol "/fresh_table" `shouldRespondWith` 201+ -- The new table behaves as a sqlar archive.+ put "/fresh_table/note.txt" "hello"+ `shouldRespondWith` 201+ get "/fresh_table/note.txt"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "hello"+ }++ it "rejects MKCOL on an existing table with 405" $ do+ mkcol "/users" `shouldRespondWith` 405++ it "inserts a row when MKCOL targets a missing rowid" $ do+ mkcol "/users/777" `shouldRespondWith` 201+ -- All other columns are NULL on the freshly inserted row.+ get "/users/777/name" `shouldRespondWith` 200++ it "returns 405 when the rowid already exists" $ do+ mkcol "/users/1" `shouldRespondWith` 405++ it "returns 403 when MKCOL points at a cell" $ do+ mkcol "/users/1/name" `shouldRespondWith` 403++ it "rejects MKCOL with a body" $ do+ request "MKCOL" "/users/888" [("Content-Length", "1")] "x"+ `shouldRespondWith` 415++ describe "COPY" $ do+ it "copies a cell to another column of the same row" $ do+ request+ "COPY"+ "/users/1/name.txt"+ [("Destination", "/users/1/email.txt")]+ ""+ `shouldRespondWith` 204+ get "/users/1/email"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "John"+ }+ -- Source still has its value+ get "/users/1/name"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "John"+ }++ it "clones a row to a new rowid" $ do+ request+ "COPY"+ "/users/1"+ [("Destination", "/users/500")]+ ""+ `shouldRespondWith` 201+ get "/users/500/name"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "John"+ }++ it "returns 412 when the destination cell is non-NULL and Overwrite: F" $ do+ request+ "COPY"+ "/users/1/name.txt"+ [ ("Destination", "/users/2/name.txt")+ , ("Overwrite", "F")+ ]+ ""+ `shouldRespondWith` 412++ it "returns 502 for cross-table COPY" $ do+ request+ "COPY"+ "/users/1"+ [("Destination", "/other/1")]+ ""+ `shouldRespondWith` 502++ it "returns 403 when source and destination are identical" $ do+ request+ "COPY"+ "/users/1/name.txt"+ [("Destination", "/users/1/name.txt")]+ ""+ `shouldRespondWith` 403++ it "rejects mismatched shapes (cell -> row)" $ do+ request+ "COPY"+ "/users/1/name.txt"+ [("Destination", "/users/2")]+ ""+ `shouldRespondWith` 403++ describe "MOVE" $ do+ it "moves a cell value and nulls the source" $ do+ request+ "MOVE"+ "/users/1/name.txt"+ [("Destination", "/users/1/email.txt")]+ ""+ `shouldRespondWith` 204+ get "/users/1/email"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "John"+ }+ get "/users/1/name"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "NULL"+ }++ it "moves a row and deletes the source" $ do+ request+ "MOVE"+ "/users/1"+ [("Destination", "/users/600")]+ ""+ `shouldRespondWith` 201+ get "/users/600/name"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "John"+ }+ get "/users/1/name" `shouldRespondWith` 404+++{-| Regression coverage for issue #14: PROPFIND on a multi-gigabyte+table used to load every row's BLOB column into memory. This fixture+is small enough to keep the suite fast (~8 MiB across 32 rows) but+will surface a memory regression because the fixture would no longer+fit in the test process if the buggy SELECT * is reintroduced under+allocation-limited CI environments.+-}+bigBlobSpec :: Spec+bigBlobSpec = with mkBigBlobApp $ do+ describe "PROPFIND on a table with large BLOB cells (issue #14)" $ do+ it "enumerates rowids without loading BLOB content" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop>\+ \ <resourcetype/>\+ \ </prop>\+ \</propfind>\+ \"+ response <- propfind "/big_blobs/" 1 (fromString (T.unpack xmlRequest))+ let bodyTxt :: Text =+ response & simpleBody & BL.toStrict & decodeUtf8+ -- The folder root and every rowid must appear in the listing.+ liftIO+ $ for_+ ( "/big_blobs"+ : [ "/big_blobs/" <> show n+ | n <- [1 :: Int .. 32]+ ]+ )+ $ \href ->+ unless (T.isInfixOf (T.pack href) bodyTxt) $+ panic $+ "Missing href in PROPFIND response: " <> T.pack href+++{-| Fixture for PK / combined row-name tests. Creates a fresh table+@contacts@ whose primary key is the @handle@ column, plus a row in+the existing PK-less @users@ table to exercise the rowid fallback.+-}+mkRowNameApp :: RowNameMode -> IO _+mkRowNameApp mode = do+ let scratchDb = "test/rowname_scratch.sqlite"+ exists <- doesFileExist scratchDb+ unless (not exists) $ removeFile scratchDb+ withConnection scratchDb $ \conn -> do+ execute_+ conn+ "CREATE TABLE contacts (\+ \handle TEXT PRIMARY KEY, \+ \fullname TEXT, \+ \notes TEXT)"+ execute_+ conn+ "INSERT INTO contacts (handle, fullname, notes) \+ \VALUES ('alice', 'Alice Adams', 'first')"+ execute_+ conn+ "INSERT INTO contacts (handle, fullname, notes) \+ \VALUES ('bob@example.com', 'Bob Brown', 'second')"+ -- A PK-less table so we can verify the rowid fallback.+ execute_ conn "CREATE TABLE notes (body TEXT)"+ execute_ conn "INSERT INTO notes (body) VALUES ('hello')"+ pure $ webDavServer mode scratchDb+++rowNamePkSpec :: Spec+rowNamePkSpec = with (mkRowNameApp PrimaryKeyMode) $ do+ describe "PrimaryKeyMode" $ do+ it "lists rows by their PK value in PROPFIND" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop><resourcetype/></prop>\+ \</propfind>\+ \"+ response <- propfind "/contacts/" 1 (fromString (T.unpack xmlRequest))+ let bodyTxt :: Text =+ response & simpleBody & BL.toStrict & decodeUtf8+ liftIO $+ for_ ["/contacts/alice", "/contacts/bob@example.com"] $ \href ->+ unless (T.isInfixOf (T.pack href) bodyTxt) $+ panic $+ "Missing href in PROPFIND response: " <> T.pack href++ it "GET resolves a cell by PK value" $ do+ get "/contacts/alice/fullname"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "Alice Adams"+ }++ it "PUT updates a cell addressed by PK value" $ do+ put "/contacts/alice/notes.txt" "renamed"+ `shouldRespondWith` 204+ get "/contacts/alice/notes"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "renamed"+ }++ it "DELETE removes a row addressed by PK value" $ do+ delete "/contacts/bob@example.com" `shouldRespondWith` 204+ get "/contacts/bob@example.com/fullname" `shouldRespondWith` 400++ it "MKCOL inserts a new row keyed by the requested PK value" $ do+ mkcol "/contacts/carol" `shouldRespondWith` 201+ get "/contacts/carol/fullname"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "NULL"+ }++ it "rejects MKCOL when the PK value already exists" $ do+ mkcol "/contacts/alice" `shouldRespondWith` 405++ it "falls back to rowid for PK-less tables" $ do+ get "/notes/1/body"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "hello"+ }+++rowNameCombinedSpec :: Spec+rowNameCombinedSpec = with (mkRowNameApp CombinedMode) $ do+ describe "CombinedMode" $ do+ it "PROPFIND lists rows as '<rowid> - <pk>'" $ do+ let+ xmlRequest =+ normalizeXml+ "<propfind xmlns:D=\"DAV:\">\+ \ <prop><resourcetype/></prop>\+ \</propfind>\+ \"+ response <- propfind "/contacts/" 1 (fromString (T.unpack xmlRequest))+ let bodyTxt :: Text =+ response & simpleBody & BL.toStrict & decodeUtf8+ liftIO $+ for_+ [ "/contacts/1 - alice"+ , "/contacts/2 - bob@example.com"+ ]+ $ \href ->+ unless (T.isInfixOf (T.pack href) bodyTxt) $+ panic $+ "Missing href in PROPFIND response: " <> T.pack href++ it "GET accepts the combined segment" $ do+ get "/contacts/1 - alice/fullname"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "Alice Adams"+ }++ it "GET also accepts the bare rowid as a shortcut" $ do+ get "/contacts/1/fullname"+ `shouldRespondWith` ResponseMatcher+ { matchStatus = 200+ , matchHeaders = [davHeader]+ , matchBody = "Alice Adams"+ }+++main :: IO ()+main = hspec $ do+ spec+ plainSpec+ sqlarSpec+ bigBlobSpec+ rowNamePkSpec+ rowNameCombinedSpec