gemini-textboard (empty) → 0.1.0.0

raw patch · 6 files changed

+301/−0 lines, 6 filesdep +basedep +cachedep +clocksetup-changed

Dependencies added: base, cache, clock, gemini-router, gemini-server, language-gemini, network-uri, nonce, sqlite-simple, text, time, transformers

Files

CHANGELOG.md +6/−0
LICENSE +30/−0
README.md +10/−0
Setup.hs +2/−0
app/Main.hs +214/−0
gemini-textboard.cabal +39/−0

+ CHANGELOG.md view

@@ -0,0 +1,6 @@+# Revision history for gemini-textboard++## 0.1.0.0 -- 2020-07-24++* First version. Released on an unsuspecting world.+

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2020, Francesco Gazzetta++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Francesco Gazzetta nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,10 @@+# gemini-textboard++[![Hackage](https://img.shields.io/hackage/v/gemini-textboard.svg)](https://hackage.haskell.org/package/gemini-textboard)+[![builds.sr.ht status](https://builds.sr.ht/~fgaz/gemini-textboard.svg)](https://builds.sr.ht/~fgaz/gemini-textboard?)++**A barebones textboard for the Gemini protocol, written in Haskell**++This package serves also as an example for the other haskell-gemini libraries.+More info at https://sr.ht/~fgaz/haskell-gemini/+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/Main.hs view

@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Network.Gemini.Server+import Network.Gemini.Router+import Language.Gemini++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class++import Control.Concurrent (forkIO, threadDelay)++import Network.URI (parseRelativeReference)++import Data.Functor (($>))+import Data.Foldable (asum)+import Data.Maybe (fromJust)+import Data.List (intercalate)++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Encoding (encodeUtf8)++import qualified Database.SQLite.Simple as SQL+import qualified Data.Cache as Cache+import System.Clock (TimeSpec(TimeSpec))+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Format (formatTime, defaultTimeLocale, rfc822DateFormat)+import qualified Crypto.Nonce as Nonce+++data Context = Context+  { db :: SQL.Connection+  , gen :: Nonce.Generator+  , cache :: Cache.Cache Text PostType }++type ThreadId = Int++data PostType = New | Reply ThreadId++type App = RouteT (ReaderT Context IO)++main :: IO ()+main = do+  conn <- SQL.open "gemini-textboard.db"+  createTables conn+  nonceGen <- Nonce.new+  nonceCache <- Cache.newCache $ Just $ TimeSpec 300 0+  let cleanNonceCache = do+        threadDelay 300000000+        Cache.purgeExpired nonceCache+        cleanNonceCache+  _ <- forkIO cleanNonceCache+  let ctx = Context conn nonceGen nonceCache+  runServer Nothing "1964" $ runRouteT' (`runReaderT` ctx) app++-- DB stuff+-----------++createTables :: SQL.Connection -> IO ()+createTables conn = do+  SQL.execute_ conn $ "CREATE TABLE IF NOT EXISTS posts " <>+    "(id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, " <>+    "parent INTEGER, content TEXT NOT NULL, time TEXT NOT NULL, " <>+    "FOREIGN KEY(parent) REFERENCES posts(id))"+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS post_id_index ON posts (id)"+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS post_parent_index ON posts (parent)"+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS post_time_index ON posts (time)"++getAllThreads :: App [(Int, Text, UTCTime, Maybe (Int, Text, UTCTime))]+getAllThreads = do+  conn <- db <$> lift ask+  results <- liftIO $ SQL.query_ conn+    "SELECT p.id, p.content, p.time, r.id, r.content, r.time \+    \  FROM\+    \    posts AS p\+    \    OUTER LEFT JOIN (SELECT *, max(time) FROM posts GROUP BY parent) AS r\+    \  ON p.id = r.parent\+    \  WHERE p.parent IS NULL\+    \  ORDER BY IFNULL(r.time, p.time) DESC"+  pure $ fmap groupLast results+  where groupLast (opId, opTxt, opTime, lastId, lastTxt, lastTime) =+          (opId, opTxt, opTime, (,,) <$> lastId <*> lastTxt <*> lastTime)+++getThread :: ThreadId -> App (Maybe (Text, UTCTime))+getThread threadId = do+  conn <- db <$> lift ask+  liftIO $ headMaybe <$> SQL.query conn+    "SELECT content, time FROM posts WHERE id = ? AND parent IS NULL" (SQL.Only threadId)++getReplies :: ThreadId -> App [(Int, Text, UTCTime)]+getReplies threadId = do+  conn <- db <$> lift ask+  liftIO $ SQL.query conn+    "SELECT id, content, time FROM posts WHERE parent = ?" (SQL.Only threadId)++insertThread :: String -> App ThreadId+insertThread content = do+  conn <- db <$> lift ask+  now <- liftIO getCurrentTime+  liftIO $ SQL.execute conn+    "INSERT INTO posts (parent, content, time) VALUES (NULL,?,?)" (content, now)+  fmap fromIntegral $ liftIO $ SQL.lastInsertRowId conn --TODO non thread safe?++insertReply :: ThreadId -> String -> App ()+insertReply threadId content = do+  conn <- db <$> lift ask+  now <- liftIO getCurrentTime+  liftIO $ SQL.execute conn+    "INSERT INTO posts (parent, content, time) VALUES (?,?,?)"+    (threadId, content, now)++-- Nonce stuff+--------------++newNonce :: PostType -> App Text+newNonce postType = do+  ctx <- lift ask+  nonce <- Nonce.nonce128urlT $ gen ctx+  liftIO $ Cache.insert (cache ctx) nonce postType+  pure nonce++validateNonce :: Text -> App (Maybe PostType)+validateNonce nonce = do+  ctx <- lift ask+  liftIO $ Cache.lookup (cache ctx) nonce++-- Handlers+-----------++app :: App Response+app = asum+  [ end homepageHandler+  , dir "post" $ end newThreadRedirectHandler+  , dir "thread" $ capture $ \threadId -> end $ threadHandler threadId+  , dir "thread" $ capture $ \threadId -> dir "post" $ end $ threadPostRedirectHandler threadId+  , dir "p" $ capture $ \nonce -> input "Write your post" $ \post -> end $ postHandler nonce post+  ]++homepageHandler :: App Response+homepageHandler = do+  threads <- getAllThreads+  pure $ okGemini $ encodeUtf8 $ encodeGemini $+    [ LH1 "Gemini Textboard"+    , LLink "/post" $ Just "New thread"+    , LText ""+    ] <> intercalate [LText ""] (renderThread <$> threads)++renderThread :: ( ThreadId, T.Text, UTCTime+                , Maybe (Int, T.Text, UTCTime) ) -> GeminiDocument+renderThread (i, txt, t, lastReply) =+  renderOp (i, txt, t) <>+  [LText "⋮"] <>+  maybe [LText "No replies yet"] renderReply lastReply <>+  [LLink (LT.pack $ "/thread/" <> show i) $ Just "Go to thread"]++threadHandler :: String -> App Response+threadHandler threadId' = do+  let threadId = read threadId' :: Int --TODO better parsing --TODO check existence+  Just (op, opTime) <- getThread threadId+  replies <- getReplies threadId+  pure $ okGemini $ encodeUtf8 $ encodeGemini $+    [ LH1 "Gemini Textboard"+    , LLink "/" $ Just "Back to thread list"+    , LText ""+    ] <> renderOp (threadId, op, opTime) <> [LText ""] <>+    intercalate [LText ""] (renderReply <$> replies) <>+    [LText "", LLink ("/thread/" <> LT.pack (show threadId) <> "/post") $ Just "New reply"]++renderOp :: (ThreadId, T.Text, UTCTime) -> GeminiDocument+renderOp (i, txt, t) =+  [ LH2 $ "#" <> LT.pack (show i) <>+          " - Anonymous - " <> --TODO use client cert for "tripcode"+          LT.pack (formatTime defaultTimeLocale rfc822DateFormat t)+  , LText $ LT.fromStrict txt+  ]++renderReply :: (Int, T.Text, UTCTime) -> GeminiDocument+renderReply (i, txt, t) =+  [ LH3 $ "#" <> LT.pack (show i) <>+          " - Anonymous - " <> --TODO use client cert for "tripcode"+          LT.pack (formatTime defaultTimeLocale rfc822DateFormat t)+  , LText $ LT.fromStrict txt+  ]++threadPostRedirectHandler :: String -> App Response+threadPostRedirectHandler threadId' = do+  let threadId = read threadId' --TODO better parsing --TODO check existence+  nonce <- newNonce $ Reply threadId+  pure $ redirect $ fromJust $ parseRelativeReference $ "/p/" <> T.unpack nonce++newThreadRedirectHandler :: App Response+newThreadRedirectHandler = do+  nonce <- newNonce New+  pure $ redirect $ fromJust $ parseRelativeReference $ "/p/" <> T.unpack nonce++postHandler :: String -> String -> App Response+postHandler nonce content = do+  Just postType <- validateNonce (T.pack nonce) --TODO decent error handling (or is MonadFail ok?)+  threadId <- case postType of+    New -> insertThread content+    Reply threadId -> insertReply threadId content $> threadId+  pure $ redirect $ fromJust $ parseRelativeReference $ "/thread/" <> show threadId++-- Utils+--------++headMaybe :: [a] -> Maybe a+headMaybe (a:_) = Just a+headMaybe []    = Nothing+

+ gemini-textboard.cabal view

@@ -0,0 +1,39 @@+cabal-version:       2.2++name:                gemini-textboard+version:             0.1.0.0+synopsis:            A barebones textboard for the Gemini protocol+-- description:+homepage:            https://sr.ht/~fgaz/haskell-gemini/+bug-reports:         https://todo.sr.ht/~fgaz/haskell-gemini+license:             BSD-3-Clause+license-file:        LICENSE+author:              Francesco Gazzetta+maintainer:          Francesco Gazzetta <fgaz@fgaz.me>+copyright:           © 2020 Francesco Gazzetta and contributors+category:            Gemini+extra-source-files:  CHANGELOG.md, README.md++source-repository head+  type:                git+  location:            https://git.sr.ht/~fgaz/gemini-textboard++executable gemini-textboard+  main-is:             Main.hs+  other-extensions:    OverloadedStrings+  build-depends:       base ^>=4.13.0.0 || ^>=4.14.0.0+                     , gemini-server ^>=0.1.0.0+                     , gemini-router ^>=0.1.0.0+                     , language-gemini ^>=0.1.0.0+                     , nonce ^>=1.0.7+                     , cache ^>=0.1.3.0+                     , sqlite-simple ^>=0.4.18.0+                     , clock ^>=0.8+                     , text ^>=1.2.3.2+                     , time ^>=1.9.3 || ^>=1.10+                     , network-uri ^>=2.6.3.0 || ^>=2.7.0.0+                     , transformers ^>=0.5.6.2+  hs-source-dirs:      app+  ghc-options:         -Wall+  default-language:    Haskell2010+