diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ # Revision history for gemini-textboard +## 0.2.0.1 -- 2021-03-19 + +* Update gemini-server dependency (TLS resumption fix) + +## 0.2.0.0 -- 2021-02-22 + +* SSL/TLS + - stunnel is no longer necessary + - when present, the client certificate is used to derive a hash pseudonym + (similar to tripcodes in classic boards) + ## 0.1.0.0 -- 2020-07-24 * First version. Released on an unsuspecting world. - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,3 +8,5 @@ This package serves also as an example for the other haskell-gemini libraries. More info at https://sr.ht/~fgaz/haskell-gemini/ +**I have an instance online at [gemini-textboard.fgaz.me](gemini://gemini-textboard.fgaz.me)** + diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -15,6 +15,7 @@ import Data.Functor (($>)) import Data.Foldable (asum) +import Data.Traversable (for) import Data.Maybe (fromJust) import Data.List (intercalate) @@ -29,6 +30,9 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Format (formatTime, defaultTimeLocale, rfc822DateFormat) import qualified Crypto.Nonce as Nonce +import Data.ByteString.Base64.URL (encodeBase64Unpadded) +import OpenSSL.X509 (writeDerX509) +import Crypto.Hash.SHA256 (hashlazy) data Context = Context @@ -36,10 +40,19 @@ , gen :: Nonce.Generator , cache :: Cache.Cache Text PostType } -type ThreadId = Int +type PostId = Int -data PostType = New | Reply ThreadId +data PostType = New | Reply PostId +data Post = Post + { postId :: PostId + , postContent :: Text + , postAuthor :: Maybe Text + , postTime :: UTCTime } + +instance SQL.FromRow Post where + fromRow = Post <$> SQL.field <*> SQL.field <*> SQL.field <*> SQL.field + type App = RouteT (ReaderT Context IO) main :: IO () @@ -54,7 +67,7 @@ cleanNonceCache _ <- forkIO cleanNonceCache let ctx = Context conn nonceGen nonceCache - runServer Nothing "1964" $ runRouteT' (`runReaderT` ctx) app + runServer Nothing "1965" "cert.pem" "cert.pem" $ runRouteT' (`runReaderT` ctx) app -- DB stuff ----------- @@ -63,55 +76,58 @@ 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, " <> + "parent INTEGER, content TEXT NOT NULL, author TEXT, 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 :: App [(Post, Maybe Post)] getAllThreads = do conn <- db <$> lift ask results <- liftIO $ SQL.query_ conn - "SELECT p.id, p.content, p.time, r.id, r.content, r.time \ + "SELECT p.id, p.content, p.author, p.time, r.id, r.content, r.author, 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) + pure $ fmap mkPosts results + where mkPosts (opId, opTxt, opAuthor, opTime, lastId, lastTxt, lastAuthor, lastTime) = + (Post opId opTxt opAuthor opTime, Post <$> lastId <*> lastTxt <*> Just lastAuthor <*> lastTime) -getThread :: ThreadId -> App (Maybe (Text, UTCTime)) +getThread :: PostId -> App (Maybe Post) 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) + "SELECT id, content, author, time FROM posts WHERE id = ? AND parent IS NULL" (SQL.Only threadId) -getReplies :: ThreadId -> App [(Int, Text, UTCTime)] +getReplies :: PostId -> App [Post] getReplies threadId = do conn <- db <$> lift ask liftIO $ SQL.query conn - "SELECT id, content, time FROM posts WHERE parent = ?" (SQL.Only threadId) + "SELECT id, content, author, time FROM posts WHERE parent = ?" (SQL.Only threadId) -insertThread :: String -> App ThreadId +insertThread :: String -> App PostId insertThread content = do conn <- db <$> lift ask now <- liftIO getCurrentTime + author <- getAuthor liftIO $ SQL.execute conn - "INSERT INTO posts (parent, content, time) VALUES (NULL,?,?)" (content, now) + "INSERT INTO posts (parent, content, author, time) VALUES (NULL,?,?,?)" + (content, author, now) fmap fromIntegral $ liftIO $ SQL.lastInsertRowId conn --TODO non thread safe? -insertReply :: ThreadId -> String -> App () +insertReply :: PostId -> String -> App () insertReply threadId content = do conn <- db <$> lift ask now <- liftIO getCurrentTime + author <- getAuthor liftIO $ SQL.execute conn - "INSERT INTO posts (parent, content, time) VALUES (?,?,?)" - (threadId, content, now) + "INSERT INTO posts (parent, content, author, time) VALUES (?,?,?,?)" + (threadId, content, author, now) -- Nonce stuff -------------- @@ -128,6 +144,18 @@ ctx <- lift ask liftIO $ Cache.lookup (cache ctx) nonce +-- Obtaining an author id +------------------------- + +getAuthor :: App (Maybe Text) +getAuthor = do + maybeCert <- requestCert <$> getRequest + for maybeCert $ \c -> do + -- Huge hack, but it works reasonably well. + -- Ideally one should only hash the pk parameters. + der <- liftIO $ writeDerX509 c + pure $ encodeBase64Unpadded $ hashlazy der + -- Handlers ----------- @@ -138,6 +166,7 @@ , 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 + , dir "robots.txt" $ end robotsTxt ] homepageHandler :: App Response @@ -149,43 +178,45 @@ , 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) <> +renderThread :: (Post, Maybe Post) -> GeminiDocument +renderThread (op, lastReply) = + renderOp op <> [LText "⋮"] <> maybe [LText "No replies yet"] renderReply lastReply <> - [LLink (LT.pack $ "/thread/" <> show i) $ Just "Go to thread"] + [LLink (LT.pack $ "/thread/" <> show (postId op)) $ 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 + Just op <- getThread threadId replies <- getReplies threadId pure $ okGemini $ encodeUtf8 $ encodeGemini $ [ LH1 "Gemini Textboard" , LLink "/" $ Just "Back to thread list" , LText "" - ] <> renderOp (threadId, op, opTime) <> [LText ""] <> + ] <> renderOp op <> [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) = +renderOp :: Post -> GeminiDocument +renderOp (Post i txt author t) = [ LH2 $ "#" <> LT.pack (show i) <> - " - Anonymous - " <> --TODO use client cert for "tripcode" + " - " <> renderAuthor author <> " - " <> LT.pack (formatTime defaultTimeLocale rfc822DateFormat t) , LText $ LT.fromStrict txt ] -renderReply :: (Int, T.Text, UTCTime) -> GeminiDocument -renderReply (i, txt, t) = +renderReply :: Post -> GeminiDocument +renderReply (Post i txt author t) = [ LH3 $ "#" <> LT.pack (show i) <> - " - Anonymous - " <> --TODO use client cert for "tripcode" + " - " <> renderAuthor author <> " - " <> LT.pack (formatTime defaultTimeLocale rfc822DateFormat t) , LText $ LT.fromStrict txt ] +renderAuthor :: Maybe Text -> LT.Text +renderAuthor = maybe "Anonymous" LT.fromStrict + threadPostRedirectHandler :: String -> App Response threadPostRedirectHandler threadId' = do let threadId = read threadId' --TODO better parsing --TODO check existence @@ -205,10 +236,16 @@ Reply threadId -> insertReply threadId content $> threadId pure $ redirect $ fromJust $ parseRelativeReference $ "/thread/" <> show threadId +robotsTxt :: App Response +robotsTxt = pure $ okGemini $ encodeUtf8 + "User-agent: *\n\ + \# Do not crawl submission pages\n\ + \Disallow: /post/\n\ + \Disallow: /p/" + -- Utils -------- headMaybe :: [a] -> Maybe a headMaybe (a:_) = Just a headMaybe [] = Nothing - diff --git a/gemini-textboard.cabal b/gemini-textboard.cabal --- a/gemini-textboard.cabal +++ b/gemini-textboard.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: gemini-textboard -version: 0.1.0.0 +version: 0.2.0.1 synopsis: A barebones textboard for the Gemini protocol -- description: homepage: https://sr.ht/~fgaz/haskell-gemini/ @@ -21,9 +21,10 @@ 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 + build-depends: base ^>=4.12.0.0 || ^>=4.13.0.0 || ^>=4.14.0.0 + -- blocked on sqlite-simple || ^>=4.15.0.0 + , gemini-server ^>=0.3.0.0 + , gemini-router ^>=0.1.1.0 , language-gemini ^>=0.1.0.0 , nonce ^>=1.0.7 , cache ^>=0.1.3.0 @@ -33,7 +34,9 @@ , time ^>=1.9.3 || ^>=1.10 , network-uri ^>=2.6.3.0 || ^>=2.7.0.0 , transformers ^>=0.5.6.2 + , cryptohash-sha256 ^>=0.11.102 + , base64 ^>=0.4.2 + , HsOpenSSL ^>=0.11.5.1 hs-source-dirs: app - ghc-options: -Wall + ghc-options: -Wall -threaded default-language: Haskell2010 -