version 0.1.0.1

Reviewed-on: https://codeberg.org/jlamothe/gemcap/pulls/3

ChangeLog.md

@@ -1,3 +1,6 @@
-# Changelog for gemserv
+# Changelog for gemcap
 
-## Unreleased changes
+## 0.1.0.1
+
+- updated underlying libraries to more current versions
+- fixed a bug that would cause the server to crash when the client aborted the handshake by rejecting the key

README.md

@@ -1,4 +1,4 @@
-# gemserv
+# gemcap
 
 Cooyright (C) Jonathan Lamothe <jonathan@jlamothe.net>
 
@@ -15,3 +15,16 @@ Affero General Public License for more details.
 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/>.
+
+## Executive Summary
+
+This library is inspired very heavily by the
+[gemini-server](https://hackage.haskell.org/package/gemini-server)
+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

@@ -0,0 +1,72 @@
+cabal-version: 2.2
+
+-- This file has been generated from package.yaml by hpack version 0.35.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           gemcap
+version:        0.1.0.1
+synopsis:       a simple Gemini capsule (server)
+description:    a simple Gemini capsule (server) - see README.md for details
+category:       Gemini
+homepage:       https://codeberg.org/jlamothe/gemcap
+bug-reports:    https://codeberg.org/jlamothe/gemcap/issues
+author:         Jonathan Lamothe
+maintainer:     jonathan@jlamothe.net
+copyright:      2021 Jonathan Lamothe
+license:        AGPL-3.0-or-later
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+library
+  exposed-modules:
+      Network.Gemini.Capsule
+      Network.Gemini.Capsule.Encoding
+      Network.Gemini.Capsule.Internal
+      Network.Gemini.Capsule.Types
+  other-modules:
+      Paths_gemcap
+  hs-source-dirs:
+      src
+  ghc-options: -Wall
+  build-depends:
+      base >=4.7 && <5
+    , 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 >=1.5.8 && <1.6
+    , transformers
+    , x509
+  default-language: Haskell2010
+  autogen-modules: Paths_gemcap
+
+test-suite gemcap-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Network.Gemini.Capsule.EncodingSpec
+      Network.Gemini.Capsule.InternalSpec
+      Network.Gemini.CapsuleSpec
+      Paths_gemcap
+  hs-source-dirs:
+      test
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , bytestring >=0.11.3.1 && <0.12
+    , gemcap
+    , 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 >=1.5.8 && <1.6
+    , transformers
+    , x509
+  default-language: Haskell2010
+  autogen-modules: Paths_gemcap

gemserv.cabal

@@ -1,64 +0,0 @@
-cabal-version: 2.2
-
--- This file has been generated from package.yaml by hpack version 0.34.4.
---
--- see: https://github.com/sol/hpack
-
-name:           gemserv
-version:        0.0.0
-synopsis:       Basic Gemini server
-description:    Please see the README on GitHub at <https://github.com/jlamothe/gemserv#readme>
-category:       Gemini
-homepage:       https://github.com/jlamothe/gemserv#readme
-bug-reports:    https://github.com/jlamothe/gemserv/issues
-author:         Jonathan Lamothe
-maintainer:     jonathan@jlamothe.net
-copyright:      2021 Jonathan Lamothe
-license:        AGPL-3.0-or-later
-license-file:   LICENSE
-build-type:     Simple
-extra-source-files:
-    README.md
-    ChangeLog.md
-
-source-repository head
-  type: git
-  location: https://github.com/jlamothe/gemserv
-
-library
-  exposed-modules:
-      Network.GemServ
-      Network.GemServ.Types
-  other-modules:
-      Paths_gemserv
-  hs-source-dirs:
-      src
-  ghc-options: -Wall
-  build-depends:
-      base >=4.7 && <5
-    , bytestring >=0.10.12.0 && <0.11
-    , tcp-streams >=1.0.1.1 && <1.1
-    , text >=1.2.4.1 && <1.3
-    , tls
-    , x509
-  default-language: Haskell2010
-
-test-suite gemserv-test
-  type: exitcode-stdio-1.0
-  main-is: Spec.hs
-  other-modules:
-      Network.GemServSpec
-      Paths_gemserv
-  hs-source-dirs:
-      test
-  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      base >=4.7 && <5
-    , bytestring >=0.10.12.0 && <0.11
-    , gemserv
-    , hspec >=2.7.10 && <2.8
-    , tcp-streams >=1.0.1.1 && <1.1
-    , text >=1.2.4.1 && <1.3
-    , tls
-    , x509
-  default-language: Haskell2010

package.yaml

@@ -1,6 +1,5 @@
-name:                gemserv
+name:                gemcap
-version:             0.0.0
+version:             0.1.0.1
-github:              "jlamothe/gemserv"
 license:             AGPL-3.0-or-later
 author:              "Jonathan Lamothe"
 maintainer:          "jonathan@jlamothe.net"
@@ -11,30 +10,37 @@ extra-source-files:
 - ChangeLog.md
 
 # Metadata used when publishing your package
-synopsis:            Basic Gemini server
+synopsis:            a simple Gemini capsule (server)
 category:            Gemini
+homepage:            https://codeberg.org/jlamothe/gemcap
+bug-reports:         https://codeberg.org/jlamothe/gemcap/issues
 
 # To avoid duplicated efforts in documentation and dealing with the
 # complications of embedding Haddock markup inside cabal files, it is
 # common to point users to the README.md file.
-description:         Please see the README on GitHub at <https://github.com/jlamothe/gemserv#readme>
+description:         a simple Gemini capsule (server) - see README.md for details
 
 ghc-options:
 - -Wall
 
 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
-- tls
+- io-streams
+- network
+- tls >= 1.5.8 && < 1.6
+- transformers
 - x509
 
 library:
   source-dirs: src
+  verbatim: &paths
+    autogen-modules: Paths_gemcap
 
 tests:
-  gemserv-test:
+  gemcap-test:
     main:                Spec.hs
     source-dirs:         test
     ghc-options:
@@ -42,5 +48,7 @@ tests:
     - -rtsopts
     - -with-rtsopts=-N
     dependencies:
-    - gemserv
+    - gemcap
-    - hspec >= 2.7.10 && < 2.8
+    - hspec >= 2.9.7 && < 2.10
+    verbatim:
+      <<: *paths

src/Network/GemServ/Types.hs

@@ -1,58 +0,0 @@
-{-|
-
-Module      : Network.GemServ.Types
-Description : Gemini Server Types
-Copyright   : (C) Jonathan Lamothe
-License     : AGPL-3.0-or-later
-Maintainer  : jonathan@jlamothe.net
-Stability   : experimental
-Portability : POSIX
-
-This program is free software: you can redistribute it and/or modify
-it under the terms of the GNU Affero General Public License as
-published by the Free Software Foundation, either version 3 of the
-License, or (at your option) any later version.
-
-This program is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-Affero General Public License for more details.
-
-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/>.
-
--}
-
-module Network.GemServ.Types (
-  GemURL (..),
-  newGemURL
-) where
-
-import Data.Word (Word32)
-
--- | Gemini URL
-data GemURL = GemURL
-  { gemHost :: String
-  -- ^ The host part of the authority section, e.g.: "example.com"
-  , gemPort :: Maybe Word32
-  -- ^ The port number (if supplied)
-  , gemPath :: [String]
-  -- ^ The decoded path segments
-  , gemQuery :: Maybe String
-  -- ^ The decoded request query (if supplied)
-  } deriving (Eq, Show)
-
--- | Builds a new 'GemURL'
-newGemURL
-  :: String
-  -- ^ The hostname
-  -> GemURL
-newGemURL host = GemURL
-  { gemHost  = host
-  , gemPort  = Nothing
-  , gemPath  = []
-  , gemQuery = Nothing
-  }
-
---jl

src/Network/Gemini/Capsule.hs

@@ -0,0 +1,100 @@
+{-|
+
+Module      : Network.Gemini.Capsule
+Description : Gemini capsule stuff
+Copyright   : (C) Jonathan Lamothe
+License     : AGPL-3.0-or-later
+Maintainer  : jonathan@jlamothe.net
+Stability   : experimental
+Portability : POSIX
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as
+published by the Free Software Foundation, either version 3 of the
+License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Affero General Public License for more details.
+
+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/>.
+
+-}
+
+{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}
+
+module Network.Gemini.Capsule (
+  runGemCapsule
+) where
+
+import Control.Concurrent (forkIO)
+import Control.Exception (SomeException, try)
+import Control.Exception.Base (bracket, finally)
+import Control.Monad (void)
+import qualified Data.Connection as C
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.TLSSetting (makeServerParams)
+import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
+import qualified Network.Socket as S
+import Network.TLS (ServerParams, onClientCertificate, serverHooks)
+import System.IO.Streams.TCP (bindAndListen)
+import System.IO.Streams.TLS (accept)
+
+import Network.Gemini.Capsule.Internal
+import Network.Gemini.Capsule.Types
+
+-- | Builds and runs a Gemini capsule
+runGemCapsule
+  :: GemCapSettings
+  -- ^ The capsule settings
+  -> GemHandler
+  -- ^ The handler
+  -> IO a
+runGemCapsule settings handler = bracket
+  ( bindAndListen
+    (capConnections settings)
+    (fromIntegral $ capPort settings)
+  )
+  S.close
+  ( \sock -> do
+    params <- makeServerParams
+      (capCert settings)
+      (capCertChain settings)
+      (capKey settings)
+    listenLoop sock params handler
+  )
+
+listenLoop :: S.Socket -> ServerParams -> GemHandler -> IO a
+listenLoop sock params handler = do
+  certRef <- newIORef Nothing
+  let params' = adjustServerParams certRef params
+  try (accept params' sock) >>= \case
+    Left (_::SomeException) -> return ()
+    Right conn            -> void $ forkIO $ finally
+      (readIORef certRef >>= runConnection conn handler)
+      (C.close conn)
+  listenLoop sock params handler
+
+adjustServerParams
+  :: IORef (Maybe Certificate)
+  -> ServerParams
+  -> ServerParams
+adjustServerParams certRef params = let
+  hooks    = serverHooks params
+  certHook = onClientCertificate hooks
+
+  certHook' chain = do
+    case chain of
+      CertificateChain []     -> return ()
+      CertificateChain (se:_) -> do
+        let cert = signedObject $ getSigned se
+        writeIORef certRef (Just cert)
+    certHook chain
+
+  hooks' = hooks { onClientCertificate = certHook' }
+  in params { serverHooks = hooks' }
+
+--jl

src/Network/Gemini/Capsule/Encoding.hs

@@ -1,7 +1,7 @@
 {-|
 
-Module      : Network.GemServ
+Module      : Network.Gemini.Capsule.Encoding
-Description : Gemini Server Stuff
+Description : funcitons to encode/decode our data types
 Copyright   : (C) Jonathan Lamothe
 License     : AGPL-3.0-or-later
 Maintainer  : jonathan@jlamothe.net
@@ -26,23 +26,29 @@ License along with this program.  If not, see
 
 {-# LANGUAGE LambdaCase, OverloadedStrings, RecordWildCards #-}
 
-module Network.GemServ (
+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')
 
-import Network.GemServ.Types
+import Network.Gemini.Capsule.Types
 
 -- | Encodes a 'GemURL' into a 'String'
 encodeGemURL :: GemURL -> String
@@ -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

@@ -0,0 +1,151 @@
+{-|
+
+Module      : Network.Gemini.Capsule.Internal
+Description : internal functions (do not use)
+Copyright   : (C) Jonathan Lamothe
+License     : AGPL-3.0-or-later
+Maintainer  : jonathan@jlamothe.net
+Stability   : experimental
+Portability : POSIX
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as
+published by the Free Software Foundation, either version 3 of the
+License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Affero General Public License for more details.
+
+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 is an internal module.  It is not intended to be accessed by
+outside packages, and should be considered subject to change at any
+time.
+
+-}
+
+{-# LANGUAGE LambdaCase #-}
+
+module Network.Gemini.Capsule.Internal (
+  runConnection,
+  readURL,
+  strFromConn,
+  readMax,
+  stripCRLF
+) where
+
+import Control.Monad (when)
+import Control.Monad.Trans.Class (lift)
+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, 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
+import Network.Gemini.Capsule.Types
+
+-- Constants
+
+-- Maximum size to read from a conneciton
+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
+  -- ^ the connection
+  -> IO (Maybe GemURL)
+readURL conn =
+  strFromConn inBufSize conn >>= return <$> \case
+    Nothing  -> Nothing
+    Just str -> decodeGemURL str
+
+-- | 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
+strFromConn
+  :: Int
+  -- ^ The maximum number of bytes to read
+  -> Connection a
+  -- ^ The connection to read from
+  -> IO (Maybe String)
+strFromConn maxLen conn = do
+  mbs <- readMax maxLen conn
+  return $ do
+    bs  <- mbs
+    txt <- case decodeUtf8' bs of
+      Left _  -> Nothing
+      Right s -> Just s
+    stripCRLF $ T.unpack txt
+
+-- | Reads from a connection up to a maximum number of bytes or a
+-- newline character is encountered, returning 'Nothing' if the limit
+-- is exceeded
+readMax
+  :: Int
+  -- ^ the maximum number of bytes
+  -> Connection a
+  -- ^ the 'Connection' to read from
+  -> IO (Maybe BS.ByteString)
+readMax maxLen conn = do
+  let src = source conn
+  runMaybeT $
+    BS.pack . BSL.unpack . toLazyByteString
+    <$> readLoop maxLen src
+
+-- | Strips the CR/LF characters from the end of a string, retuning
+-- Nothing if they are not present
+stripCRLF :: String -> Maybe String
+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
+  Nothing -> return mempty
+  Just bs -> do
+    let
+      len = BS.length bs
+      b   = byteString bs
+    when (len > maxLen) $
+      fail "maximum length exceeded"
+    if BS.any (== 0xa) bs
+      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

src/Network/Gemini/Capsule/Types.hs

@@ -0,0 +1,137 @@
+{-|
+
+Module      : Network.Gemini.Capsule.Types
+Description : Gemini capsule types
+Copyright   : (C) Jonathan Lamothe
+License     : AGPL-3.0-or-later
+Maintainer  : jonathan@jlamothe.net
+Stability   : experimental
+Portability : POSIX
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as
+published by the Free Software Foundation, either version 3 of the
+License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Affero General Public License for more details.
+
+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/>.
+
+-}
+
+module Network.Gemini.Capsule.Types (
+  -- * Types
+  GemURL (..),
+  GemRequest (..),
+  GemResponse (..),
+  GemHandler,
+  GemCapSettings (..),
+  -- * Constructors
+  newGemURL,
+  newGemRequest,
+  newGemResponse,
+  newGemCapSettings
+) where
+
+import qualified Data.ByteString.Lazy as BSL
+import Data.Word (Word8, Word16, Word32)
+import Data.X509 (Certificate)
+
+-- | Gemini URL
+data GemURL = GemURL
+  { gemHost :: String
+  -- ^ The host part of the authority section, e.g.: "example.com"
+  , gemPort :: Maybe Word32
+  -- ^ The port number (if supplied)
+  , gemPath :: [String]
+  -- ^ The decoded path segments
+  , gemQuery :: Maybe String
+  -- ^ The decoded request query (if supplied)
+  } deriving (Eq, Show)
+
+-- | Describes a Gemini request
+data GemRequest = GemRequest
+  { reqURL :: GemURL
+  -- ^ The URL being requested
+  , reqCert :: Maybe Certificate
+  -- ^ The client certificate (if available)
+  } deriving (Eq, Show)
+
+-- | Describes a response to a Gemini request
+data GemResponse = GemResponse
+  { respStatus :: Word8
+  -- ^ The response status code
+  , respMeta :: String
+  -- ^ The response metadata
+  , respBody :: Maybe BSL.ByteString
+  -- ^ The response body
+  } deriving (Eq, Show)
+
+-- | Handles a 'GemRequest' to produce a 'GemResponse'
+type GemHandler = GemRequest -> IO GemResponse
+
+-- | The settings required to set up a Gemini capsule
+data GemCapSettings = GemCapSettings
+  { capConnections :: Int
+  -- ^ Number of simultaneous connections allowed
+  , capPort :: Word16
+  -- ^ The capsule port number
+  , capCert :: FilePath
+  -- ^ The path to the TLS certificate
+  , capCertChain :: [FilePath]
+  -- ^ The paths to the chain certificates
+  , capKey :: FilePath
+  -- ^ The path to the private key
+  } deriving (Eq, Show)
+
+-- | Builds a new 'GemURL'
+newGemURL
+  :: String
+  -- ^ The hostname
+  -> GemURL
+newGemURL host = GemURL
+  { gemHost  = host
+  , gemPort  = Nothing
+  , gemPath  = []
+  , gemQuery = Nothing
+  }
+
+-- | Builds a 'GemRequest'
+newGemRequest
+  :: GemURL
+  -- ^ The request URL
+  -> GemRequest
+newGemRequest url = GemRequest
+  { reqURL  = url
+  , reqCert = Nothing
+  }
+
+-- | Builds a 'GemResponse'
+newGemResponse :: GemResponse
+newGemResponse = GemResponse
+  { respStatus = 20
+  , respMeta   = "text/gemini"
+  , respBody   = Nothing
+  }
+
+-- | Builds a reasonable set of server settings.
+newGemCapSettings
+  :: FilePath
+  -- ^ Path to the server certificate
+  -> FilePath
+  -- ^ Path to the private key
+  -> GemCapSettings
+newGemCapSettings cert key = GemCapSettings
+  { capConnections = 100
+  , capPort        = 1965
+  , capCert        = cert
+  , capCertChain   = []
+  , capKey         = key
+  }
+
+--jl

stack.yaml

@@ -17,8 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
+resolver: lts-20.5
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
 
 # 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:
+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
 snapshots:
 - completed:
-    size: 586268
+    sha256: a684cdbdf9304b325a503e0fe1d9648e9c18155ce4c7cfebbe8a7f93674e6295
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
+    size: 649106
-    sha256: d9e658a22cfe8d87a64fdf219885f942fef5fe2bcb156a9800174911c5da2443
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/5.yaml
-  original:
+  original: lts-20.5
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml

test/Network/Gemini/Capsule/EncodingSpec.hs

@@ -1,6 +1,6 @@
 {-
 
-gemserv
+gemcap
 
 Cooyright (C) Jonathan Lamothe <jonathan@jlamothe.net>
 
@@ -20,19 +20,22 @@ License along with this program.  If not, see
 
 -}
 
-module Network.GemServSpec (spec) where
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Gemini.Capsule.EncodingSpec (spec) where
 
 import Test.Hspec (Spec, context, describe, it, shouldBe)
 
-import Network.GemServ
+import Network.Gemini.Capsule.Encoding
-import Network.GemServ.Types
+import Network.Gemini.Capsule.Types
 
 spec :: Spec
-spec = describe "Network.GemServ" $ do
+spec = describe "Encoding" $ do
   encodeGemURLSpec
   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

@@ -0,0 +1,202 @@
+{-
+
+gemcap
+
+Cooyright (C) Jonathan Lamothe <jonathan@jlamothe.net>
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as
+published by the Free Software Foundation, either version 3 of the
+License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Affero General Public License for more details.
+
+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/>.
+
+-}
+
+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+
+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,
+  shouldBe,
+  shouldReturn)
+
+import Network.Gemini.Capsule.Types
+import Network.Gemini.Capsule.Internal
+
+spec :: Spec
+spec = describe "Internal" $ do
+  runConnectionSpec
+  readURLSpec
+  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 $
+    it ("should return " ++ show expect) $
+      do
+        conn <- ioConn
+        readURL conn `shouldReturn` expect
+  )
+
+  --  description,       connection,  expected result
+  [ ( "valid URL",       validConn,   Just validExp   )
+  , ( "long URL",        longConn,    Just longExp    )
+  , ( "too long URL",    tooLongConn, Nothing         )
+  , ( "gibberish input", gibConn,     Nothing         )
+  ]
+
+  where
+    validConn   = mkInConn ["gemini://example.com/\r\n"]
+    longConn    = mkInConn [longBS]
+    tooLongConn = mkInConn [tooLongBS]
+    gibConn     = mkInConn ["aosidjfwoeinboijwefr"]
+    longBS      = BS.pack (take 1024 bytes) <> "\r\n"
+    tooLongBS   = BS.pack (take 1025 bytes) <> "\r\n"
+    bytes       = BS.unpack prefix ++ repeat (fromIntegral $ ord 'A')
+    validExp    = newGemURL "example.com"
+    longExp     = validExp { gemPath = [longDir] }
+    longDir     = replicate (1024 - BS.length prefix) 'A'
+    prefix      = "gemini://example.com/"
+
+strFromConnSpec :: Spec
+strFromConnSpec = describe "strFromConn" $ mapM_
+  ( \(desc, maxLen, ioConn, expect) -> context desc $
+    it ("should return " ++ show expect) $ do
+      conn <- ioConn
+      strFromConn maxLen conn `shouldReturn` expect
+  )
+
+  --  description,    max size, connection,                expected
+  [ ( "valid string", 100,      mkInConn ["foo\r\n"],      Just "foo"  )
+  , ( "long string",  5,        mkInConn ["too long\r\n"], Nothing     )
+  , ( "no CR/LF",     100,      mkInConn ["foo"],          Nothing     )
+  , ( "bad UTF-8",    100,      mkInConn ["foo\xff\r\n"],  Nothing     )
+  , ( "non-ASCII",    100,      mkInConn ["\xc3\xa9\r\n"], Just "\xe9" )
+  ]
+
+readMaxSpec :: Spec
+readMaxSpec = describe "readMax" $ mapM_
+  ( \(desc, maxLen, ioConn, expect) -> context desc $
+    it ("should return " ++ show expect) $ do
+      conn <- ioConn
+      readMax maxLen conn `shouldReturn` expect
+  )
+
+  --  description,    max length,   connection,  expected
+  [ ( "single input", 1024,         singleConn,  Just singleBS )
+  , ( "multi input",  1024,         multiConn,   Just multiBS  )
+  , ( "long input",   longLen,      longConn,    Just longBS   )
+  , ( "too long",     pred longLen, longConn,    Nothing       )
+  , ( "empty input",  1024,         mkInConn [], Just ""       )
+  ]
+
+  where
+    singleConn = mkInConn ["foo"]
+    multiConn  = mkInConn ["foo", "bar", "baz"]
+    longConn   = mkInConn [longBS]
+    longLen    = BS.length longBS
+    singleBS   = "foo"
+    multiBS    = "foobarbaz"
+    longBS     = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+
+stripCRLFSpec :: Spec
+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
+  source <- nullInput
+  mapM_ (`unRead` source) (reverse bss)
+  let
+    send          = const $ return ()
+    close         = return ()
+    connExtraInfo = ()
+  return Connection {..}
+
+sampleCert :: Certificate
+sampleCert = Certificate
+  { certVersion      = undefined
+  , certSerial       = undefined
+  , certSignatureAlg = undefined
+  , certIssuerDN     = undefined
+  , certValidity     = undefined
+  , certSubjectDN    = undefined
+  , certPubKey       = undefined
+  , certExtensions   = undefined
+  }
+
+--jl

test/Network/Gemini/CapsuleSpec.hs

@@ -0,0 +1,35 @@
+{-
+
+gemcap
+
+Cooyright (C) Jonathan Lamothe <jonathan@jlamothe.net>
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as
+published by the Free Software Foundation, either version 3 of the
+License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Affero General Public License for more details.
+
+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/>.
+
+-}
+
+module Network.Gemini.CapsuleSpec (spec) where
+
+import Test.Hspec (Spec, describe)
+
+import qualified Network.Gemini.Capsule.EncodingSpec as Encoding
+import qualified Network.Gemini.Capsule.InternalSpec as Internal
+
+spec :: Spec
+spec = describe "Network.Gemini.Capsule" $ do
+  Encoding.spec
+  Internal.spec
+
+--jl

test/Spec.hs

@@ -1,6 +1,6 @@
 {-
 
-gemserv
+gemcap
 
 Cooyright (C) Jonathan Lamothe <jonathan@jlamothe.net>
 
@@ -23,9 +23,9 @@ License along with this program.  If not, see
 module Main (main) where
 
 import Test.Hspec (hspec)
-import qualified Network.GemServSpec as GemServ
+import qualified Network.Gemini.CapsuleSpec as GemCap
 
 main :: IO ()
-main = hspec GemServ.spec
+main = hspec GemCap.spec
 
 --jl