App.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

module App (app) where

import           Control.Monad.IO.Class
import           Data.Aeson.Types          (Result (Success))
import qualified Data.ByteString.Char8     as BS
import           Data.Cache
import qualified Data.HashMap.Strict       as H
import           Data.Maybe
import qualified Data.Text.Lazy            as T
import qualified Data.Vault.Lazy           as V
import           IPFS
import           Network.HTTP.Types.Status
import           Network.Wai
import           Network.Wai.Parse
import           Web.Scotty

gatewayUrl = "https://ipfs.stride.press/ipfs/"

cacheMiddleware key app req respond = do
    cache <- case V.lookup key (vault req) of
        Nothing -> newCache Nothing
        Just c  -> return c
    app (req { vault = V.insert key cache (vault req)}) respond

nameFromLs :: (Either a (Result Ls)) -> String
nameFromLs lsRoot = undefined

app (manager, authMiddleware, cacheKey) = scottyApp $ do
    middleware authMiddleware
    middleware $ cacheMiddleware cacheKey

    get "/" $ file "./static/index.html"

    post "/" $ do
        f <- files
        if length f == 0
        then status status400 >> text "no u"
        else do
            let fileInfo = snd . head $ f
                content  = fileContent fileInfo
            addResp <- liftIO $ runAdd manager content
            case addResp of
                    Right (Success add') -> redirect
                                          . T.pack
                                          $ gatewayUrl
                                         ++ addHash add'
                    _                    -> raise "What the fuck dude"

    get "/pins" $ do
        pinLsResp <- liftIO $ runPinLs manager
        req <- request
        let cache = case V.lookup cacheKey (vault req) of
                Just c  -> c
                Nothing -> undefined
            pins = case pinLsResp of
                Right (Success pins') -> H.keys . pinLsKeys $ pins'
                _                     -> []
        names <- mapM (\h -> do
            n <- liftIO $ Data.Cache.lookup cache h
            name <- case n of
                Just name -> name
                Nothing   -> do
                    lsRoot <- liftIO $ runLs manager h
                    liftIO $ Data.Cache.insert cache h (nameFromLs lsRoot)
                    nameFromLs lsRoot
            return name) pins
        text . T.pack $ show names