feat(users/Profpatsch/cas-serve): init

A dumb little daemon that stores arbitrary files by content-hash, and
exposes a randomly generated URL by which the file can be fetched
again.

If the same file is uploaded twice, it will only be stored once.
CAS hashes are not exposed to the user, so they can’t figure out
whether a file they know is in the database.

Change-Id: Ie57bc09d429a9f31c8f0fc5f63f78d6a84d650f7
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5952
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

users/Profpatsch/cas-serve/CasServe.hs

@@ -0,0 +1,247 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Main where
+
+import Control.Applicative
+import qualified Crypto.Hash as Crypto
+import qualified Data.ByteArray as ByteArray
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+import qualified Data.ByteString.Lazy as Lazy
+import Data.Functor.Compose
+import Data.Int (Int64)
+import qualified Data.List as List
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import Database.SQLite.Simple (NamedParam ((:=)))
+import qualified Database.SQLite.Simple as Sqlite
+import qualified Database.SQLite.Simple.FromField as Sqlite
+import qualified Database.SQLite.Simple.QQ as Sqlite
+import GHC.TypeLits (Symbol)
+import MyPrelude
+import qualified Network.HTTP.Types as Http
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified SuperRecord as Rec
+import System.IO (stderr)
+import Control.Monad.Reader
+
+main :: IO ()
+main = do
+  withEnv $ \env ->
+    Warp.runSettings
+      (Warp.defaultSettings & Warp.setPort 7070)
+      (api env)
+
+withEnv :: (Env -> IO a) -> IO a
+withEnv inner = do
+  withSqlite "./data.sqlite" $ \envData -> do
+    withSqlite "./wordlist.sqlite" $ \envWordlist -> inner Env {..}
+
+withSqlite :: String -> (Sqlite.Connection -> IO a) -> IO a
+withSqlite fileName inner = Sqlite.withConnection fileName $ \conn -> do
+  Sqlite.setTrace conn (Just (\msg -> Text.hPutStrLn stderr [fmt|{fileName}: {msg}|]))
+  Sqlite.execute conn [Sqlite.sql|PRAGMA foreign_keys = ON|] ()
+  inner conn
+
+api :: Env -> Wai.Application
+api env req respond = do
+  case runHandler (getById <|> insertById) req env of
+    Nothing -> respond $ Wai.responseLBS Http.status404 [] "endpoint does not exist."
+    Just handler' -> do
+      handler' >>= \case
+        Left (status, err) -> respond $ Wai.responseLBS status [] (err & toLazyBytes)
+        Right (headers, body) ->
+          respond $
+            Wai.responseLBS
+              Http.status200
+              headers
+              ( body & toLazyBytes
+              )
+
+data Env = Env
+  { envWordlist :: Sqlite.Connection,
+    envData :: Sqlite.Connection
+  }
+
+-- | I don’t need any fancy routing in this, so a handler is just something that returns a @Just (IO a)@ if it wants to handle the request.
+newtype Handler a
+  = Handler ( ReaderT (Wai.Request, Env) (Compose Maybe IO) a )
+  deriving newtype (Functor, Applicative, Alternative)
+
+handler :: ((Wai.Request, Env) -> Maybe (IO a)) -> Handler a
+handler f = Handler (ReaderT (Compose . f))
+
+runHandler :: Handler a -> Wai.Request -> Env -> Maybe (IO a)
+runHandler (Handler handler') req env = getCompose $ handler' & (\readerT -> runReaderT readerT (req, env))
+
+getById ::
+  Handler
+    ( Either
+        (Http.Status, ByteString)
+        ([(Http.HeaderName, ByteString)], ByteString)
+    )
+getById = handler $ \(req, env) -> do
+  guard ((req & Wai.requestMethod) == Http.methodGet)
+  case req & Wai.pathInfo of
+    ["v0", "by-id", filename] -> Just $ do
+      Sqlite.queryNamed
+        @( Rec.Rec
+             [ "mimetype" Rec.:= Text,
+               "content" Rec.:= ByteString,
+               "size" Rec.:= Int
+             ]
+         )
+        (env & envData)
+        [Sqlite.sql|
+        SELECT
+          mimetype,
+          cast (content AS blob) as content,
+          size
+        FROM file_content
+        JOIN file_references
+          ON file_references.file_content = file_content.hash_sha256
+        WHERE
+          file_references.reference_type = 'by-id'
+          AND (file_references.name || file_references.extension) = :filename
+       |]
+        [":filename" Sqlite.:= filename]
+        <&> \case
+          [] -> Left (Http.status404, "File not found.")
+          [res] ->
+            Right
+              ( [ ("Content-Type", res & Rec.get #mimetype & textToBytesUtf8),
+                  ("Content-Length", res & Rec.get #size & showToText & textToBytesUtf8)
+                ],
+                -- TODO: should this be lazy/streamed?
+                res & Rec.get #content
+              )
+          _more -> Left "file_references must be unique (in type and name)" & unwrapError
+    _ -> Nothing
+
+insertById :: Handler (Either a ([(Http.HeaderName, ByteString)], ByteString))
+insertById = handler $ \(req, env) -> do
+  guard ((req & Wai.requestMethod) == Http.methodPost)
+  case req & Wai.pathInfo of
+    ["v0", "by-id"] -> Just $ do
+      let maybeText bytes = case bytesToTextUtf8 bytes of
+            Left _err -> Nothing
+            Right t -> Just t
+      let mimeType =
+            ( (req & Wai.requestHeaders & List.lookup "X-Cas-Serve-Mimetype" >>= maybeText)
+                <|> (req & Wai.requestHeaders & List.lookup "Content-Type" >>= maybeText)
+            )
+              & fromMaybe "application/octet-stream"
+
+      let magicFileEnding mimeType' = case Text.split (== '/') mimeType' of
+            [_, ""] -> Nothing
+            ["", _] -> Nothing
+            [_, "any"] -> Nothing
+            ["image", ty] -> Just (Text.cons '.' ty)
+            ["video", ty] -> Just (Text.cons '.' ty)
+            ["text", "plain"] -> Just ".txt"
+            ["text", "html"] -> Just ".html"
+            ["application", "pdf"] -> Just ".pdf"
+            ["application", "json"] -> Just ".json"
+            _ -> Nothing
+
+      let extension =
+            ( (req & Wai.requestHeaders & List.lookup "X-Cas-Serve-FileExtension" >>= maybeText)
+                <|> ( (req & Wai.requestHeaders & List.lookup "Content-Type")
+                        >>= maybeText
+                        >>= magicFileEnding
+                    )
+            )
+              -- Just the empty extension if we can’t figure it out.
+              & fromMaybe ""
+
+      body <- Wai.consumeRequestBodyStrict req
+      let hash :: Crypto.Digest Crypto.SHA256 = Crypto.hashlazy body
+      let hashBytes = hash & ByteArray.convert @(Crypto.Digest Crypto.SHA256) @ByteString
+      let len = ByteString.Lazy.length body
+      name <- getNameFromWordlist env
+      let fullname = name <> extension
+
+      let conn = env & envData
+      Sqlite.withTransaction conn $ do
+        Sqlite.executeNamed
+          conn
+          [Sqlite.sql|
+            INSERT INTO file_content
+              (content, hash_sha256, size)
+              VALUES
+              (:content, :hash_sha256, :size)
+              ON CONFLICT (hash_sha256) DO NOTHING
+          |]
+          [ ":content" := (body :: Lazy.ByteString),
+            ":hash_sha256" := (hashBytes :: ByteString),
+            ":size" := (len :: Int64)
+          ]
+
+        -- TODO: we are not checking if the name already exists,
+        -- we just assume that 1633^3 is enough to not get any collisions for now.
+        -- If the name exists, the user gets a 500.
+        Sqlite.executeNamed
+          conn
+          [Sqlite.sql|
+            INSERT INTO file_references
+              (file_content, reference_type, name, extension, mimetype)
+            VALUES
+              (:file_content, :reference_type, :name, :extension, :mimetype)
+          |]
+          [ ":file_content" := (hashBytes :: ByteString),
+            ":reference_type" := ("by-id" :: Text),
+            ":name" := name,
+            ":extension" := (extension :: Text),
+            ":mimetype" := (mimeType :: Text)
+          ]
+      pure $
+        Right
+          ( [("Content-Type", "text/plain")],
+            [fmt|/v0/by-id/{fullname}|]
+          )
+    _ -> Nothing
+
+-- Get a random name from a wordlist, that is three words connected by @-@.
+getNameFromWordlist :: Env -> IO Text
+getNameFromWordlist env =
+  do
+    let numberOfWords = 3 :: Int
+    Sqlite.queryNamed @(Sqlite.Only Text)
+      (env & envWordlist)
+      [Sqlite.sql|SELECT word FROM wordlist ORDER BY RANDOM() LIMIT :words|]
+      [":words" Sqlite.:= numberOfWords]
+    <&> map Sqlite.fromOnly
+    <&> Text.intercalate "-"
+
+-- | We can use a Rec with a named list of types to parse a returning row of sqlite!!
+instance
+  ( Rec.UnsafeRecBuild rec rec FromFieldC
+  ) =>
+  Sqlite.FromRow (Rec.Rec rec)
+  where
+  fromRow = do
+    Rec.unsafeRecBuild @rec @rec @FromFieldC (\_lbl _proxy -> Sqlite.field)
+
+class (Sqlite.FromField a) => FromFieldC (lbl :: Symbol) a
+
+instance (Sqlite.FromField a) => FromFieldC lbl a

users/Profpatsch/cas-serve/cas-serve.cabal

@@ -0,0 +1,24 @@
+cabal-version:      2.4
+name:               cas-serve
+version:            0.1.0.0
+author:             Profpatsch
+maintainer:         mail@profpatsch.de
+
+executable cas-serve
+    main-is:          CasServe.hs
+
+    build-depends:
+        base ^>=4.15.1.0,
+        text,
+        sqlite-simple,
+        http-types,
+        wai,
+        warp,
+        mtl,
+        my-prelude,
+        bytestring,
+        memory,
+        cryptonite,
+        superrecord
+
+    default-language: Haskell2010

users/Profpatsch/cas-serve/default.nix

@@ -0,0 +1,27 @@
+{ depot, pkgs, lib, ... }:
+
+let
+  cas-serve = pkgs.writers.writeHaskell "cas-serve"
+    {
+      libraries = [
+        pkgs.haskellPackages.wai
+        pkgs.haskellPackages.warp
+        pkgs.haskellPackages.sqlite-simple
+        depot.users.Profpatsch.my-prelude
+        (pkgs.haskell.lib.dontCheck
+          (pkgs.haskell.lib.overrideSrc pkgs.haskellPackages.superrecord {
+            src = pkgs.fetchFromGitHub {
+              owner = "Profpatsch";
+              repo = "superrecord";
+              rev = "c00e933f582e3fb8d209f6cece91d464faf09082";
+              sha256 = "sha256-UQ2wCoBpUEPcRsI7wNOFGH+vceKF4dcbbGHFVVTkOWw=";
+            };
+          }))
+
+      ];
+      ghcArgs = [ "-threaded" ];
+
+    } ./CasServe.hs;
+
+in
+cas-serve

users/Profpatsch/cas-serve/schema.sql

@@ -0,0 +1,38 @@
+-- SQLite
+.dump
+
+PRAGMA foreign_keys = ON;
+
+BEGIN transaction;
+
+create table if not exists file_content (
+  content blob NOT NULL,
+  hash_sha256 blob PRIMARY KEY,
+  size integer NOT NULL
+) WITHOUT ROWID;
+
+
+create table if not exists file_references (
+  rowid integer PRIMARY KEY,
+  file_content NOT NULL REFERENCES file_content ON DELETE CASCADE,
+  reference_type text NOT NULL,
+  name text NOT NULL,
+  extension text NOT NULL,
+  mimetype text NOT NULL
+);
+
+create unique index if not exists file_references_type_name_unique on file_references (reference_type, name);
+
+-- insert into file_content values ('mycontent', 'myhash', 9);
+-- insert into file_references values (NULL, 'myhash', 'by-id', 'myschranz', '.txt', 'text/plain');
+-- insert into file_content values (readfile('/home/philip/Pictures/screenshot.png'), 'anotherhash', 999);
+-- insert into file_references values (NULL, 'anotherhash', 'by-id', 'img', '.png', 'image/png');
+
+select * from file_content;
+
+select * from file_references;
+
+COMMIT;
+
+-- drop table file_content;
+-- drop table file_references;