248 lines
8.6 KiB
Haskell
248 lines
8.6 KiB
Haskell
|
{-# 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
|