catch *any* exception

`listenLoop` was crashing when the client closed the connection during the handshake.  How this doesn't qualify as an `IOException` is beyond me.

ChangeLog.md

@@ -1,3 +1,5 @@
 # Changelog for gemcap
 
 ## Unreleased changes
+
+- fixed a bug that would cause the server to crash when the client aborted the handshake by rejecting the key

README.md

@@ -16,11 +16,6 @@ You should have received a copy of the GNU Affero General Public
 License along with this program.  If not, see
 <https://www.gnu.org/licenses/>.
 
-## Important Note
-
-This project is not yet ready for release. Everything within it should
-be considered unstable and subject to change at any time.
-
 ## Executive Summary
 
 This library is inspired very heavily by the
@@ -28,3 +23,8 @@ This library is inspired very heavily by the
 package, but does not need to be linked against OpenSSL. Instead, it
 uses [tcp-streams](https://hackage.haskell.org/package/tcp-streams) to
 provide TLS functionality.
+
+## Pull Requests
+
+Pull requests welcome.  That said, please make your pull requests to
+the `dev` branch.

gemcap.cabal

@@ -1,11 +1,11 @@
 cabal-version: 2.2
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
 name:           gemcap
-version:        0.0.0
+version:        0.1.0
 synopsis:       a simple Gemini capsule (server)
 description:    a simple Gemini capsule (server) - see README.md for details
 category:       Gemini
@@ -34,12 +34,12 @@ library
   ghc-options: -Wall
   build-depends:
       base >=4.7 && <5
-    , bytestring >=0.10.12.0 && <0.11
+    , bytestring >=0.11.3.1 && <0.12
     , io-streams
     , network
     , tcp-streams >=1.0.1.1 && <1.1
     , text >=1.2.4.1 && <1.3
-    , tls
+    , tls >=1.5.8 && <1.6
     , transformers
     , x509
   default-language: Haskell2010
@@ -58,14 +58,14 @@ test-suite gemcap-test
   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
-    , bytestring >=0.10.12.0 && <0.11
+    , bytestring >=0.11.3.1 && <0.12
     , gemcap
-    , hspec >=2.7.10 && <2.8
+    , hspec >=2.9.7 && <2.10
     , io-streams
     , network
     , tcp-streams >=1.0.1.1 && <1.1
     , text >=1.2.4.1 && <1.3
-    , tls
+    , tls >=1.5.8 && <1.6
     , transformers
     , x509
   default-language: Haskell2010

package.yaml

@@ -1,5 +1,5 @@
 name:                gemcap
-version:             0.0.0
+version:             0.1.0
 license:             AGPL-3.0-or-later
 author:              "Jonathan Lamothe"
 maintainer:          "jonathan@jlamothe.net"
@@ -25,12 +25,12 @@ ghc-options:
 
 dependencies:
 - base >= 4.7 && < 5
-- bytestring >= 0.10.12.0 && < 0.11
+- bytestring >= 0.11.3.1 && < 0.12
 - tcp-streams >= 1.0.1.1 && < 1.1
 - text >= 1.2.4.1 && < 1.3
 - io-streams
 - network
-- tls
+- tls >= 1.5.8 && < 1.6
 - transformers
 - x509
 
@@ -49,6 +49,6 @@ tests:
     - -with-rtsopts=-N
     dependencies:
     - gemcap
-    - hspec >= 2.7.10 && < 2.8
+    - hspec >= 2.9.7 && < 2.10
     verbatim:
       <<: *paths

src/Network/Gemini/Capsule.hs

@@ -31,7 +31,7 @@ module Network.Gemini.Capsule (
 ) where
 
 import Control.Concurrent (forkIO)
-import Control.Exception (IOException, try)
+import Control.Exception (SomeException, try)
 import Control.Exception.Base (bracket, finally)
 import Control.Monad (void)
 import qualified Data.Connection as C
@@ -72,7 +72,7 @@ listenLoop sock params handler = do
   certRef <- newIORef Nothing
   let params' = adjustServerParams certRef params
   try (accept params' sock) >>= \case
-    Left (_::IOException) -> return ()
+    Left (_::SomeException) -> return ()
     Right conn            -> void $ forkIO $ finally
       (readIORef certRef >>= runConnection conn handler)
       (C.close conn)
@@ -97,18 +97,4 @@ adjustServerParams certRef params = let
   hooks' = hooks { onClientCertificate = certHook' }
   in params { serverHooks = hooks' }
 
-runConnection
-  :: C.Connection a
-  -> GemHandler
-  -> Maybe Certificate
-  -> IO ()
-runConnection conn handler mCert =
-  ( readURL conn >>= \case
-    Nothing -> return $ newGemResponse
-      { respStatus = 59
-      , respMeta   = "bad request"
-      }
-    Just url -> handler (newGemRequest url) { reqCert = mCert }
-  ) >>= sendResponse conn
-
 --jl

src/Network/Gemini/Capsule/Encoding.hs

@@ -30,15 +30,21 @@ module Network.Gemini.Capsule.Encoding (
   encodeGemURL,
   decodeGemURL,
   escapeString,
-  unescapeString
+  unescapeString,
+  encodeGemResponse
 ) where
 
 import qualified Data.ByteString as BS
-import Data.ByteString.Builder (charUtf8, stringUtf8, toLazyByteString)
+import Data.ByteString.Builder (
+  charUtf8,
+  lazyByteString,
+  stringUtf8,
+  toLazyByteString,
+  word8Dec)
 import qualified Data.ByteString.Lazy as BSL
 import Data.Char (chr, ord, toLower)
 import Data.List (find, intercalate)
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, fromMaybe)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8')
 
@@ -137,6 +143,22 @@ unescapeString str = case decodeUtf8' $ BS.pack $ toBytes str of
     toNum ch = fst $ fromJust $
       find (\x -> snd x == ch) $ zip [0..] hexDigits
 
+-- | encodes a 'GemResponse' into a lazy ByteString
+encodeGemResponse :: GemResponse -> BSL.ByteString
+encodeGemResponse resp = let
+  code = respStatus resp
+  meta = respMeta resp
+  body = fromMaybe "" $ respBody resp
+
+  builder
+    =  word8Dec code
+    <> charUtf8 ' '
+    <> stringUtf8 meta
+    <> stringUtf8 "\r\n"
+    <> lazyByteString body
+
+  in toLazyByteString builder
+
 hexDigits :: String
 hexDigits = ['0'..'9'] ++ ['a'..'f']
 

src/Network/Gemini/Capsule/Internal.hs

@@ -33,8 +33,8 @@ time.
 {-# LANGUAGE LambdaCase #-}
 
 module Network.Gemini.Capsule.Internal (
+  runConnection,
   readURL,
-  sendResponse,
   strFromConn,
   readMax,
   stripCRLF
@@ -46,9 +46,10 @@ import Control.Monad.Trans.Maybe (MaybeT (..))
 import qualified Data.ByteString as BS
 import Data.ByteString.Builder (Builder, byteString, toLazyByteString)
 import qualified Data.ByteString.Lazy as BSL
-import Data.Connection (Connection, source)
+import Data.Connection (Connection, send, source)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8')
+import Data.X509 (Certificate)
 import qualified System.IO.Streams as S
 
 import Network.Gemini.Capsule.Encoding
@@ -60,6 +61,21 @@ import Network.Gemini.Capsule.Types
 inBufSize :: Int
 inBufSize = 1026
 
+-- | process a request and return a response over a 'Connection'
+runConnection
+  :: Connection a
+  -> GemHandler
+  -> Maybe Certificate
+  -> IO ()
+runConnection conn handler mCert =
+  ( readURL conn >>= \case
+    Nothing -> return $ newGemResponse
+      { respStatus = 59
+      , respMeta   = "bad request"
+      }
+    Just url -> handler (newGemRequest url) { reqCert = mCert }
+  ) >>= sendResponse conn
+
 -- | Reads a 'GemURL' from a 'Connection'
 readURL
   :: Connection a
@@ -70,15 +86,6 @@ readURL conn =
     Nothing  -> Nothing
     Just str -> decodeGemURL str
 
--- | Sends a 'GemResponse' to a 'Connection'
-sendResponse
-  :: Connection a
-  -- ^ the connection
-  -> GemResponse
-  -- ^ the response being sent
-  -> IO ()
-sendResponse = undefined
-
 -- | Reads up to a maxumum number of bytes from a 'Connection', UTF-8
 -- decodes it, and returns the resulting string (if possible) without
 -- the trailing CR/LF
@@ -115,7 +122,10 @@ readMax maxLen conn = do
 -- | Strips the CR/LF characters from the end of a string, retuning
 -- Nothing if they are not present
 stripCRLF :: String -> Maybe String
-stripCRLF = undefined
+stripCRLF = \case
+  ""     -> Nothing
+  "\r\n" -> Just ""
+  c:str  -> (c:) <$> stripCRLF str
 
 readLoop :: Int -> S.InputStream BS.ByteString -> MaybeT IO Builder
 readLoop maxLen src = lift (S.read src) >>= \case
@@ -130,4 +140,12 @@ readLoop maxLen src = lift (S.read src) >>= \case
       then return b
       else (b <>) <$> readLoop (maxLen - len) src
 
+sendResponse
+  :: Connection a
+  -- ^ the connection
+  -> GemResponse
+  -- ^ the response being sent
+  -> IO ()
+sendResponse conn resp = send conn $ encodeGemResponse resp
+
 --jl

stack.yaml

@@ -17,8 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
+resolver: lts-20.5
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -40,8 +39,6 @@ packages:
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
-extra-deps:
-- tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack.yaml.lock

@@ -3,18 +3,10 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages:
-- completed:
-    hackage: tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329
-    pantry-tree:
-      size: 1004
-      sha256: 572071fca40a0b6c4cc950d10277a6f12e83cf4846882b6ef83fcccaa2c18c45
-  original:
-    hackage: tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329
+packages: []
 snapshots:
 - completed:
-    size: 586268
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
-    sha256: d9e658a22cfe8d87a64fdf219885f942fef5fe2bcb156a9800174911c5da2443
-  original:
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
+    sha256: a684cdbdf9304b325a503e0fe1d9648e9c18155ce4c7cfebbe8a7f93674e6295
+    size: 649106
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/5.yaml
+  original: lts-20.5

test/Network/Gemini/Capsule/EncodingSpec.hs

@@ -20,6 +20,8 @@ License along with this program.  If not, see
 
 -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Network.Gemini.Capsule.EncodingSpec (spec) where
 
 import Test.Hspec (Spec, context, describe, it, shouldBe)
@@ -33,6 +35,7 @@ spec = describe "Encoding" $ do
   decodeGemURLSpec
   escapeStringSpec
   unescapeStringSpec
+  encodeGemResponseSpec
 
 encodeGemURLSpec :: Spec
 encodeGemURLSpec = describe "encodeGemURL" $ mapM_
@@ -143,4 +146,12 @@ unescapeStringSpec = describe "unescapeString" $ mapM_
   , ( "foo%ff",    Nothing        )
   ]
 
+encodeGemResponseSpec :: Spec
+encodeGemResponseSpec = describe "encodeGemResponse" $
+  it ("should be " ++ show expect) $
+    encodeGemResponse resp `shouldBe` expect
+  where
+    resp   = newGemResponse { respBody = Just "Success!\r\n" }
+    expect = "20 text/gemini\r\nSuccess!\r\n"
+
 --jl

test/Network/Gemini/Capsule/InternalSpec.hs

@@ -25,26 +25,70 @@ License along with this program.  If not, see
 module Network.Gemini.Capsule.InternalSpec (spec) where
 
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
 import Data.Char (ord)
 import Data.Connection (Connection (..))
+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
+import Data.X509 (Certificate (..))
 import System.IO.Streams (nullInput, unRead)
-import Test.Hspec (Spec, context, describe, it, shouldReturn, xit)
+import Test.Hspec (
+  Spec,
+  context,
+  describe,
+  it,
+  shouldBe,
+  shouldReturn)
 
 import Network.Gemini.Capsule.Types
 import Network.Gemini.Capsule.Internal
 
 spec :: Spec
 spec = describe "Internal" $ do
+  runConnectionSpec
   readURLSpec
-  sendResponseSpec
   strFromConnSpec
   readMaxSpec
   stripCRLFSpec
 
+runConnectionSpec :: Spec
+runConnectionSpec = describe "runConnection" $ mapM_
+  ( \(desc, ioConnRef, handler, mCert, expect) -> context desc $
+    it ("should return " ++ show expect) $ do
+      (conn, outRef) <- ioConnRef
+      runConnection conn handler mCert
+      readIORef outRef `shouldReturn` expect
+  )
+
+  --  description,            connection,  handler, certificate,     expectation
+  [ ( "basic connection",     basicConn,   basicH,  Nothing,         basicExp    )
+  , ( "no certificate",       basicConn,   certH,   Nothing,         noCertExp   )
+  , ( "with certificate",     basicConn,   certH,   Just sampleCert, basicExp    )
+  , ( "gibberish with CR/LF", gibConnCRLF, basicH,  Nothing,         gibExp      )
+  , ( "gibberish w/o CR/LF",  gibConn,     basicH,  Nothing,         gibExp      )
+  ]
+
+  where
+    basicConn   = mkIOConn ["gemini://example.com/\r\n"]
+    gibConnCRLF = mkIOConn ["aosidjgfoeribjeworifj\r\n"]
+    gibConn     = mkIOConn ["sodifjboije"]
+    basicH _    = return newGemResponse { respBody = Just success }
+
+    certH req = return $ case reqCert req of
+      Nothing -> newGemResponse
+        { respStatus = 60
+        , respMeta   = "certificate required"
+        }
+      Just _ -> newGemResponse { respBody = Just success }
+
+    basicExp  = ["20 text/gemini\r\nSuccess!\r\n"]
+    noCertExp = ["60 certificate required\r\n"]
+    gibExp    = ["59 bad request\r\n"]
+    success   = "Success!\r\n"
+
 readURLSpec :: Spec
 readURLSpec = describe "readURL" $ mapM_
   ( \(desc, ioConn, expect) -> context desc $
-    xit ("should return " ++ show expect) $
+    it ("should return " ++ show expect) $
       do
         conn <- ioConn
         readURL conn `shouldReturn` expect
@@ -70,13 +114,10 @@ readURLSpec = describe "readURL" $ mapM_
     longDir     = replicate (1024 - BS.length prefix) 'A'
     prefix      = "gemini://example.com/"
 
-sendResponseSpec :: Spec
-sendResponseSpec = describe "sendResponse" $ return ()
-
 strFromConnSpec :: Spec
 strFromConnSpec = describe "strFromConn" $ mapM_
   ( \(desc, maxLen, ioConn, expect) -> context desc $
-    xit ("should return " ++ show expect) $ do
+    it ("should return " ++ show expect) $ do
       conn <- ioConn
       strFromConn maxLen conn `shouldReturn` expect
   )
@@ -115,7 +156,26 @@ readMaxSpec = describe "readMax" $ mapM_
     longBS     = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 
 stripCRLFSpec :: Spec
-stripCRLFSpec = describe "stripCRLF" $ return ()
+stripCRLFSpec = describe "stripCRLF" $ mapM_
+  ( \(input, expected) -> context (show input) $
+    it ("should be" ++ show expected) $
+      stripCRLF input `shouldBe` expected
+  )
+
+  --  input,     expectation
+  [ ( "foo\r\n", Just "foo"  )
+  , ( "foo\n",   Nothing     )
+  , ( "foo",     Nothing     )
+  , ( "\r\n",    Just ""     )
+  ]
+
+mkIOConn :: [BS.ByteString] -> IO (Connection (), IORef [BSL.ByteString])
+mkIOConn input = do
+  ref  <- newIORef []
+  conn <-
+    ( \c -> c { send = \bs -> modifyIORef' ref (++[bs]) }
+    ) <$> mkInConn input
+  return (conn, ref)
 
 mkInConn :: [BS.ByteString] -> IO (Connection ())
 mkInConn bss = do
@@ -127,4 +187,16 @@ mkInConn bss = do
     connExtraInfo = ()
   return Connection {..}
 
+sampleCert :: Certificate
+sampleCert = Certificate
+  { certVersion      = undefined
+  , certSerial       = undefined
+  , certSignatureAlg = undefined
+  , certIssuerDN     = undefined
+  , certValidity     = undefined
+  , certSubjectDN    = undefined
+  , certPubKey       = undefined
+  , certExtensions   = undefined
+  }
+
 --jl