mirror of https://github.com/voidlizard/hbs2
390 lines
11 KiB
Haskell
390 lines
11 KiB
Haskell
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# Language TypeOperators #-}
|
|
module HttpWorker where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.OrDie
|
|
import HBS2.Base58
|
|
import HBS2.Hash
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Storage
|
|
import HBS2.Data.Detect
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Merkle
|
|
import HBS2.Net.Messaging.Pipe
|
|
import HBS2.Peer.Proto hiding (Request)
|
|
import HBS2.Peer.Proto.BrowserPlugin hiding (Request)
|
|
import HBS2.Peer.Proto.LWWRef
|
|
import HBS2.Peer.Browser.Assets
|
|
import HBS2.Net.Auth.Schema (HBS2Basic)
|
|
import HBS2.Data.Types.SignedBox
|
|
import HBS2.Events
|
|
import HBS2.Storage.Operations.ByteString
|
|
import HBS2.Misc.PrettyStuff
|
|
|
|
|
|
import PeerTypes
|
|
import PeerConfig
|
|
import RefLog ( doRefLogBroadCast )
|
|
import Browser
|
|
|
|
import Data.Config.Suckless
|
|
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Network.HTTP.Types.Status
|
|
import Network.Wai.Middleware.RequestLogger
|
|
import Network.Wai.Middleware.StaticEmbedded
|
|
import Network.Wai
|
|
import Web.Scotty as Scotty
|
|
|
|
import Data.ByteString.Builder (byteString, Builder)
|
|
|
|
import Codec.Serialise (deserialiseOrFail)
|
|
import Control.Monad.Except
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.Cont
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.Function
|
|
import Data.Aeson (object, (.=))
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
|
import Data.ByteString.Char8 qualified as BS8
|
|
import Data.Either
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.Maybe
|
|
import Data.List qualified as List
|
|
import Data.Text qualified as Text
|
|
import Data.Text.Lazy qualified as LT
|
|
import Data.Text.Encoding qualified as Text
|
|
import Lens.Micro.Platform (view)
|
|
import Streaming.Prelude qualified as S
|
|
import System.FilePath
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
import System.Process.Typed
|
|
import System.Environment
|
|
|
|
import UnliftIO hiding (orElse)
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
-- TODO: introduce-http-of-off-feature
|
|
|
|
extractMetadataHash :: Hash HbSync -> LBS.ByteString -> Maybe (Hash HbSync)
|
|
extractMetadataHash what blob =
|
|
case tryDetect what blob of
|
|
MerkleAnn (MTreeAnn {_mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption}) -> Just h
|
|
_ -> Nothing
|
|
|
|
orElse :: m r -> Maybe a -> ContT r m a
|
|
orElse a mb = ContT $ maybe1 mb a
|
|
|
|
|
|
data Plugin =
|
|
Plugin
|
|
{
|
|
}
|
|
|
|
pattern Spawn :: forall {c}. [Syntax c] -> Syntax c
|
|
pattern Spawn args <- ListVal (SymbolVal "spawn" : args)
|
|
|
|
runPlugin :: forall m . MonadUnliftIO m
|
|
=> RefChanId L4Proto
|
|
-> [FilePath]
|
|
-> TVar (HashMap (RefChanId L4Proto) (ServiceCaller BrowserPluginAPI PIPE))
|
|
-> m ()
|
|
|
|
runPlugin _ [] _ = pure ()
|
|
runPlugin pks (self:args) handles = do
|
|
|
|
let cmd = proc self args
|
|
& setStdin createPipe
|
|
& setStdout createPipe
|
|
-- & setStderr closed
|
|
|
|
forever do
|
|
flip runContT pure do
|
|
|
|
debug $ yellow "started channel plugin" <+> pretty (AsBase58 pks) <+> pretty self
|
|
|
|
p <- ContT $ withProcessWait cmd
|
|
|
|
let ssin = getStdin p
|
|
let sout = getStdout p
|
|
client <- newMessagingPipe (sout,ssin)
|
|
|
|
void $ ContT $ withAsync $ runMessagingPipe client
|
|
|
|
debug $ red "RUNNING PLUGIN!"
|
|
|
|
caller <- makeServiceCaller @BrowserPluginAPI @PIPE (localPeer client)
|
|
|
|
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClient caller) client
|
|
|
|
ContT $ bracket (atomically $ modifyTVar handles (HM.insert pks caller))
|
|
(const $ atomically $ modifyTVar handles (HM.delete pks))
|
|
|
|
void $ waitExitCode p
|
|
|
|
|
|
findPlugins :: forall m . MonadIO m => [Syntax C] -> m [(Maybe Text, RefChanId L4Proto, [FilePath])]
|
|
findPlugins syn = w $ S.toList_ $ do
|
|
|
|
let chans = mconcat [ channels b | ListVal (SymbolVal "browser" : b) <- syn ]
|
|
|
|
for_ chans $ \cha -> void $ runMaybeT do
|
|
|
|
rchan <- toMPlus $ headMay $
|
|
catMaybes [ fromStringMay @(RefChanId L4Proto) (Text.unpack x)
|
|
| ListVal [SymbolVal "refchan", LitStrVal x] <- cha
|
|
]
|
|
|
|
let alias = headMay [ x
|
|
| ListVal [SymbolVal "alias", LitStrVal x] <- cha
|
|
]
|
|
|
|
plug <- toMPlus $ headMay $ catMaybes $
|
|
[ mkProcessArgs what
|
|
| ListVal [ SymbolVal "plugin", Spawn what ] <- cha
|
|
]
|
|
|
|
debug $ red "FOUND CHANNEL" <+> pretty (AsBase58 rchan) <+> parens (pretty plug)
|
|
|
|
lift $ S.yield (alias, rchan, plug)
|
|
|
|
where
|
|
|
|
w l = l >>= uniq
|
|
|
|
uniq s = pure (List.nubBy ((==) `on` ukey) s)
|
|
where ukey (a,b,_) = (a,b)
|
|
|
|
mkProcessArgs ssyn = sequence $
|
|
flip fmap ssyn \case
|
|
LitStrVal s -> Just (Text.unpack s)
|
|
SymbolVal (Id s) -> Just (Text.unpack s)
|
|
_ -> Nothing
|
|
|
|
|
|
channels bro = [ chan
|
|
| ListVal (SymbolVal "channel" : chan) <- bro
|
|
]
|
|
|
|
httpWorker :: forall e s m . ( MyPeer e
|
|
, MonadIO m
|
|
, HasStorage m
|
|
, IsRefPubKey s
|
|
, s ~ Encryption e
|
|
, m ~ PeerM e IO
|
|
, e ~ L4Proto
|
|
-- , ForLWWRefProto e
|
|
) => PeerConfig -> AnnMetaData -> DownloadEnv e -> m ()
|
|
|
|
httpWorker (PeerConfig syn) pmeta e = do
|
|
|
|
sto <- getStorage
|
|
let port' = runReader (cfgValue @PeerHttpPortKey) syn <&> fromIntegral
|
|
let bro = runReader (cfgValue @PeerBrowserEnable) syn == FeatureOn
|
|
penv <- ask
|
|
|
|
void $ flip runContT pure do
|
|
|
|
handles <- newTVarIO mempty
|
|
|
|
aliases <- newTVarIO (mempty :: HashMap Text (RefChanId L4Proto))
|
|
|
|
plugins <- findPlugins syn
|
|
|
|
for_ plugins $ \(a, r, args) -> do
|
|
for_ a $ \alias -> atomically $ modifyTVar aliases (HM.insert alias r)
|
|
void $ ContT $ withAsync (runPlugin r args handles)
|
|
|
|
port <- ContT $ maybe1 port' none
|
|
|
|
liftIO $ scotty port $ do
|
|
middleware logStdout
|
|
|
|
defaultHandler $ const do
|
|
status status500
|
|
|
|
get "/size/:hash" do
|
|
|
|
what <- param @String "hash" <&> fromString
|
|
size <- liftIO $ hasBlock sto what
|
|
case size of
|
|
Nothing -> status status404
|
|
Just n -> do
|
|
json n
|
|
|
|
-- TODO: key-to-disable-tree-streaming
|
|
|
|
get "/ref/:key" do
|
|
|
|
void $ flip runContT pure do
|
|
what <- lift (param @String "key" <&> fromStringMay @(LWWRefKey HBS2Basic))
|
|
>>= orElse (status status404)
|
|
|
|
rv <- getRef sto what
|
|
>>= orElse (status status404)
|
|
>>= getBlock sto
|
|
>>= orElse (status status404)
|
|
<&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef e) e)
|
|
>>= orElse (status status404)
|
|
<&> unboxSignedBox0 @(LWWRef e)
|
|
>>= orElse (status status404)
|
|
<&> lwwValue . snd
|
|
|
|
lift $ getTreeHash sto rv
|
|
|
|
-- TODO: define-parsable-instance-for-our-types
|
|
get "/tree/:hash" do
|
|
what <- param @String "hash" <&> fromString
|
|
getTreeHash sto what
|
|
|
|
get "/cat/:hash" do
|
|
what <- param @String "hash" <&> fromString
|
|
blob <- liftIO $ getBlock sto what
|
|
case blob of
|
|
Nothing -> status status404
|
|
Just lbs -> do
|
|
addHeader "content-type" "application/octet-stream"
|
|
addHeader "content-length" [qc|{LBS.length lbs}|]
|
|
raw lbs
|
|
|
|
get "/reflog/:ref" do
|
|
re <- param @String "ref" <&> fromStringMay
|
|
case re of
|
|
Nothing -> status status404
|
|
Just ref -> do
|
|
va <- liftIO $ getRef sto (RefLogKey @s ref)
|
|
maybe1 va (status status404) $ \val -> do
|
|
text [qc|{pretty val}|]
|
|
|
|
-- FIXME: to-replace-to-rpc
|
|
post "/reflog" do
|
|
bs <- LBS.take 4194304 <$> body
|
|
let msg' =
|
|
deserialiseOrFail @(RefLogUpdate L4Proto) bs
|
|
& either (const Nothing) Just
|
|
case msg' of
|
|
Nothing -> do
|
|
status status400
|
|
json $ object ["error" .= "unable to parse RefLogUpdate message"]
|
|
Just msg -> do
|
|
let pubk = view refLogId msg
|
|
liftIO $ withPeerM penv $ do
|
|
emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, msg, Nothing))
|
|
doRefLogBroadCast msg
|
|
status status200
|
|
|
|
get "/metadata" do
|
|
raw $ serialise $ pmeta
|
|
|
|
middleware (static cssDir)
|
|
|
|
|
|
let pluginPath = function $ \r -> case splitDirectories (BS8.unpack (rawPathInfo r)) of
|
|
("/" : "browser" : plugin : _ ) -> Just [("plugin", LT.pack plugin)]
|
|
_ -> Nothing
|
|
|
|
when bro do
|
|
|
|
get "/browser" do
|
|
renderTextT (browserRootPage syn) >>= html
|
|
|
|
get pluginPath do
|
|
|
|
req <- Scotty.request
|
|
|
|
let rawPath = BS8.unpack (rawPathInfo req)
|
|
|
|
debug $ red "BROWSER" <+> viaShow (splitDirectories rawPath)
|
|
|
|
url <- param @Text "plugin"
|
|
alias <- readTVarIO aliases <&> HM.lookup url
|
|
|
|
-- args <- param @String "1"
|
|
|
|
void $ flip runContT pure do
|
|
|
|
chan <- maybe (fromStringMay $ Text.unpack url) pure alias
|
|
& orElse (status status404)
|
|
|
|
plugin <- readTVarIO handles <&> HM.lookup chan
|
|
>>= orElse (status status404)
|
|
|
|
let pp = splitDirectories rawPath
|
|
let norm = fromMaybe pp $ List.stripPrefix ["/","browser",Text.unpack url] pp
|
|
let q = Get (Text.pack <$> norm) (("RAW_PATH_INFO", fromString rawPath) : mempty)
|
|
|
|
debug $ red "CALL PLUGIN" <+> viaShow q
|
|
|
|
lift $ renderTextT (pluginPage plugin q) >>= html
|
|
|
|
|
|
put "/" do
|
|
-- FIXME: optional-header-based-authorization
|
|
-- signed nonce + peer key?
|
|
|
|
-- TODO: ddos-protection
|
|
-- FIXME: fix-max-size-hardcode
|
|
bs <- LBS.take 4194304 <$> body
|
|
-- let ha = hashObject @HbSync bs
|
|
-- here <- liftIO $ hasBlock sto ha <&> isJust
|
|
|
|
mbHash <- liftIO $ putBlock sto bs
|
|
|
|
case mbHash of
|
|
Nothing -> status status500
|
|
Just h -> text [qc|{pretty h}|]
|
|
|
|
warn "http port not set"
|
|
forever $ pause @'Seconds 600
|
|
|
|
|
|
|
|
getTreeHash :: AnyStorage -> HashRef -> ActionM ()
|
|
getTreeHash sto what' = void $ flip runContT pure do
|
|
blob <- liftIO (getBlock sto what)
|
|
>>= orElse (status status404)
|
|
|
|
mh <- orElse (status status404) (extractMetadataHash what blob)
|
|
|
|
meta <- lift (getBlock sto mh) >>= orElse (status status404)
|
|
<&> LBS8.unpack
|
|
<&> fromRight mempty . parseTop
|
|
|
|
let tp = headDef "application/octet-stream"
|
|
[ show (pretty w)
|
|
| ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta
|
|
]
|
|
|
|
let fn = headMay
|
|
[ show (pretty w)
|
|
| ListVal [SymbolVal "file-name:", LitStrVal w] <- meta
|
|
]
|
|
|
|
-- liftIO $ print $ pretty meta
|
|
|
|
case fn of
|
|
Just x | takeExtension x == ".html" -> pure ()
|
|
| otherwise -> lift $ do
|
|
addHeader "content-disposition" [qc|attachment; filename="{x}"|]
|
|
|
|
_ -> pure ()
|
|
|
|
lift $ addHeader "content-type" (fromString tp)
|
|
|
|
elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey what)
|
|
|
|
case elbs of
|
|
Left{} -> lift $ status status404
|
|
Right lbs -> lift do
|
|
stream $ \write flush -> do
|
|
for_ (LBS.toChunks lbs) $ \chunk -> do
|
|
write $ byteString chunk
|
|
flush
|
|
where
|
|
what = fromHashRef what'
|
|
|
|
|