diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,86 @@ +# SQLiteDAV + +WebDAV server that maps an SQLite database to directories/files. + +| | | +---|--- +Database Schema | ![SQL Schema Code](./images/2023-10-16t1031_sql.png) +File View | ![Screenshot of macOS Finder](./images/2023-10-17t2031_finder.png) + + +## 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 diff --git a/SQLiteDAV.cabal b/SQLiteDAV.cabal new file mode 100644 --- /dev/null +++ b/SQLiteDAV.cabal @@ -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 + @\.\@ 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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) diff --git a/src/SQLiteDAV/API.hs b/src/SQLiteDAV/API.hs new file mode 100644 --- /dev/null +++ b/src/SQLiteDAV/API.hs @@ -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 diff --git a/src/SQLiteDAV/HTTPExtensions.hs b/src/SQLiteDAV/HTTPExtensions.hs new file mode 100644 --- /dev/null +++ b/src/SQLiteDAV/HTTPExtensions.hs @@ -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 @@ +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 diff --git a/src/SQLiteDAV/MimeDetect.hs b/src/SQLiteDAV/MimeDetect.hs new file mode 100644 --- /dev/null +++ b/src/SQLiteDAV/MimeDetect.hs @@ -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 diff --git a/src/SQLiteDAV/Properties.hs b/src/SQLiteDAV/Properties.hs new file mode 100644 --- /dev/null +++ b/src/SQLiteDAV/Properties.hs @@ -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 [] + ) + ) diff --git a/src/SQLiteDAV/SQLAR.hs b/src/SQLiteDAV/SQLAR.hs new file mode 100644 --- /dev/null +++ b/src/SQLiteDAV/SQLAR.hs @@ -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 . +-} +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 <> "\"" diff --git a/src/SQLiteDAV/Server.hs b/src/SQLiteDAV/Server.hs new file mode 100644 --- /dev/null +++ b/src/SQLiteDAV/Server.hs @@ -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 @\ - \@ + (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) diff --git a/src/SQLiteDAV/Utils.hs b/src/SQLiteDAV/Utils.hs new file mode 100644 --- /dev/null +++ b/src/SQLiteDAV/Utils.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 $ + "" + <> ( xmlRequest + & T.replace " "1, 2, ordered-collections" + + +xmlHeader :: MatchHeader +xmlHeader = "Content-Type" <:> "application/xml" + + +rmModified :: WaiSession st SResponse -> WaiSession st SResponse +rmModified fRes = + let + regex :: BL.ByteString = "([^<>]+)" + in + fRes + <&> ( \sres -> + let + bodyTxt :: Text = + sres + & simpleBody + & BL.toStrict + & decodeUtf8 + timestampMatch :: Text = + bodyTxt =~ regex + simpleBodyNew = + bodyTxt + & T.replace + timestampMatch + "REMOVED" + & 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 + "\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \\ + \" + + 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 + "\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /users\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \\ + \" + 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 + "\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /users\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /users/1\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /users/2\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /users/3\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \\ + \" + 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 + "\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /users/1\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /users/1/name.txt\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ REMOVED\ + \ 4\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /users/1/email.txt\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ REMOVED\ + \ 16\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /users/1/height.txt\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ REMOVED\ + \ 3\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /users/1/photo.png\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ REMOVED\ + \ 135872\ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \\ + \" + + 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 + "\ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /users/1\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ \ + \ /users/2\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ \ + \ /users/3\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \\ + \" + 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 + "\ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /users\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \\ + \" + 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 + "\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /users\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \\ + \" + 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")] + "" + `shouldRespondWith` 400 + + it "returns 400 when a prefix is bound to the empty namespace" $ do + request + "PROPFIND" + "/" + [(hContentType, "application/xml"), ("Depth", "0")] + ( "" + <> "" + <> "" + ) + `shouldRespondWith` 400 + + it "Prefer can combine depth-noroot and return=minimal" $ do + let + xmlRequest = + normalizeXml + "\ + \ \ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /users/1\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ \ + \ /users/2\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \ \ + \ /users/3\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ REMOVED\ + \ \ + \ \ + \ \ + \\ + \" + 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 + "\ + \ \ + \ \ + \ \ + \ http://example.com/owner\ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ \ + \ \ + \ \ + \ infinity\ + \ Second-604800\ + \ \ + \ urn:uuid:00000000-0000-0000-0000-000000000001\ + \ \ + \ \ + \ /users/1/name.txt\ + \ \ + \ \ + \ \ + \\ + \" + result = lock "/users/1/name.txt" (fromString (T.unpack xmlRequest)) + + result + `shouldRespondWith` ResponseMatcher + { matchStatus = 200 + , matchHeaders = + [ davHeader + , xmlHeader + , "Lock-Token" + <:> "" + ] + , matchBody = fromString (T.unpack xmlResponse) + } + + describe "UNLOCK" $ do + it "returns 204 No Content" $ do + unlock + "/users/1/name.txt" + "" + `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 + "\ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /sqlar\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /sqlar/docs\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /sqlar/readme.txt\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ 11\ + \ \ + \ \ + \ \ + \\ + \" + + 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 + "\ + \ \ + \ \ + \ \ + \ \ + \\ + \" + xmlResponse = + normalizeXml + "\ + \ \ + \ /sqlar/docs\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /sqlar/docs/guide\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ HTTP/1.1 404 Not Found\ + \ \ + \ \ + \ \ + \ \ + \ Property was not found\ + \ \ + \ \ + \ \ + \ \ + \ /sqlar/docs/intro.md\ + \ \ + \ HTTP/1.1 200 OK\ + \ \ + \ 8\ + \ \ + \ \ + \ \ + \\ + \" + + 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 + "\ + \ \ + \\ + \" + 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 + "\ + \ \ + \ \ + \ \ + \\ + \" + 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 + "\ + \ \ + \\ + \" + 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 ' - '" $ do + let + xmlRequest = + normalizeXml + "\ + \ \ + \\ + \" + 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