implemented basic logic for readURL

This commit is contained in:
Jonathan Lamothe 2021-11-18 20:00:52 -05:00
parent 893ab49256
commit 5c83bf3123
8 changed files with 386 additions and 238 deletions

View File

@ -24,6 +24,7 @@ extra-source-files:
library
exposed-modules:
Network.Gemini.Capsule
Network.Gemini.Capsule.Encoding
Network.Gemini.Capsule.Internal
Network.Gemini.Capsule.Types
other-modules:
@ -34,6 +35,7 @@ library
build-depends:
base >=4.7 && <5
, bytestring >=0.10.12.0 && <0.11
, io-streams
, network
, tcp-streams >=1.0.1.1 && <1.1
, text >=1.2.4.1 && <1.3
@ -46,6 +48,7 @@ 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
@ -57,6 +60,7 @@ test-suite gemcap-test
, bytestring >=0.10.12.0 && <0.11
, gemcap
, hspec >=2.7.10 && <2.8
, io-streams
, network
, tcp-streams >=1.0.1.1 && <1.1
, text >=1.2.4.1 && <1.3

View File

@ -28,6 +28,7 @@ dependencies:
- bytestring >= 0.10.12.0 && < 0.11
- tcp-streams >= 1.0.1.1 && < 1.1
- text >= 1.2.4.1 && < 1.3
- io-streams
- network
- tls
- x509

View File

@ -24,36 +24,18 @@ License along with this program. If not, see
-}
{-# LANGUAGE
LambdaCase,
OverloadedStrings,
ScopedTypeVariables,
RecordWildCards #-}
{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}
module Network.Gemini.Capsule (
-- * Running a Gemini Server
runGemCapsule,
-- * Encoding/Decoding Functions
encodeGemURL,
decodeGemURL,
escapeString,
unescapeString
runGemCapsule
) where
import Control.Concurrent (forkIO)
import Control.Exception (IOException, try)
import Control.Exception.Base (bracket, finally)
import Control.Monad (void)
import qualified Data.ByteString as BS
import Data.ByteString.Builder (charUtf8, stringUtf8, toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Char (chr, ord, toLower)
import qualified Data.Connection as C
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (find, intercalate)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8')
import Data.TLSSetting (makeServerParams)
import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
import qualified Network.Socket as S
@ -85,106 +67,13 @@ runGemCapsule settings handler = bracket
listenLoop sock params handler
)
-- | Encodes a 'GemURL' into a 'String'
encodeGemURL :: GemURL -> String
encodeGemURL url =
"gemini://" ++ authority ++ "/" ++ path ++ query
where
authority = gemHost url ++ case gemPort url of
Just port -> ':' : show port
Nothing -> ""
path = intercalate "/" $ map escapeString $ gemPath url
query = case gemQuery url of
Nothing -> ""
Just q -> '?' : escapeString q
-- | Decodes a 'GemURL' from a 'String' (if possible)
decodeGemURL :: String -> Maybe GemURL
decodeGemURL str = do
let txt = T.pack str
noProt <- case T.splitOn "://" txt of
[prot, rest] -> if T.toLower prot == "gemini"
then Just rest
else Nothing
_ -> Nothing
noFrag <- case T.splitOn "#" noProt of
[x, _] -> Just x
[x] -> Just x
_ -> Nothing
(noQuery, query) <- case T.splitOn "?" noFrag of
[nq, q] -> Just (nq, Just q)
[nq] -> Just (nq, Nothing)
_ -> Nothing
gemQuery <- case query of
Just q -> Just <$> unescapeString (T.unpack q)
Nothing -> Just Nothing
(auth, path) <- case T.splitOn "/" noQuery of
[a] -> Just (a, [])
[a, ""] -> Just (a, [])
a:ps -> Just (a, ps)
_ -> Nothing
gemPath <- mapM (unescapeString . T.unpack) path
(host, gemPort) <- case T.splitOn ":" auth of
[h, p] -> case reads $ T.unpack p of
[(n, "")] -> Just (h, Just n)
_ -> Nothing
[h] -> Just (h, Nothing)
_ -> Nothing
let gemHost = T.unpack host
Just GemURL {..}
-- | add required escape sequences to a string
escapeString :: String -> String
escapeString = concatMap
( \n -> let ch = chr $ fromIntegral n in
if ch `elem` unescaped
then [ch]
else '%' : toHex n
) . BSL.unpack . toLazyByteString . stringUtf8
where
unescaped = ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z'] ++ "~-_."
toHex =
( \n -> let
high = n `div` 16
low = n `mod` 16
in [hexDigits !! high, hexDigits !! low]
) . fromIntegral
-- | decode an escaped string back to its original value
unescapeString :: String -> Maybe String
unescapeString str = case decodeUtf8' $ BS.pack $ toBytes str of
Right t -> Just $ T.unpack t
_ -> Nothing
where
toBytes = \case
"" -> []
'%':h:l:sub -> let
h' = toLower h
l' = toLower l
in if h' `elem` hexDigits && l' `elem` hexDigits
then toByte h' l' : toBytes sub
else fromIntegral (ord '%') : toBytes (h : l : sub)
ch:sub ->
BSL.unpack (toLazyByteString $ charUtf8 ch) ++ toBytes sub
toByte h l = toNum h * 16 + toNum l
toNum ch = fst $ fromJust $
find (\x -> snd x == ch) $ zip [0..] hexDigits
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 (_ :: IOException) -> return ()
Right conn -> void $ forkIO $ finally
Left (_::IOException) -> return ()
Right conn -> void $ forkIO $ finally
(readIORef certRef >>= runConnection conn handler)
(C.close conn)
listenLoop sock params handler
@ -222,7 +111,4 @@ runConnection conn handler mCert =
Just url -> handler (newGemRequest url) { reqCert = mCert }
) >>= sendResponse conn
hexDigits :: String
hexDigits = ['0'..'9'] ++ ['a'..'f']
--jl

View File

@ -0,0 +1,143 @@
{-|
Module : Network.Gemini.Capsule.Encoding
Description : funcitons to encode/decode our data 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/>.
-}
{-# LANGUAGE LambdaCase, OverloadedStrings, RecordWildCards #-}
module Network.Gemini.Capsule.Encoding (
encodeGemURL,
decodeGemURL,
escapeString,
unescapeString
) where
import qualified Data.ByteString as BS
import Data.ByteString.Builder (charUtf8, stringUtf8, toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Char (chr, ord, toLower)
import Data.List (find, intercalate)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8')
import Network.Gemini.Capsule.Types
-- | Encodes a 'GemURL' into a 'String'
encodeGemURL :: GemURL -> String
encodeGemURL url =
"gemini://" ++ authority ++ "/" ++ path ++ query
where
authority = gemHost url ++ case gemPort url of
Just port -> ':' : show port
Nothing -> ""
path = intercalate "/" $ map escapeString $ gemPath url
query = case gemQuery url of
Nothing -> ""
Just q -> '?' : escapeString q
-- | Decodes a 'GemURL' from a 'String' (if possible)
decodeGemURL :: String -> Maybe GemURL
decodeGemURL str = do
let txt = T.pack str
noProt <- case T.splitOn "://" txt of
[prot, rest] -> if T.toLower prot == "gemini"
then Just rest
else Nothing
_ -> Nothing
noFrag <- case T.splitOn "#" noProt of
[x, _] -> Just x
[x] -> Just x
_ -> Nothing
(noQuery, query) <- case T.splitOn "?" noFrag of
[nq, q] -> Just (nq, Just q)
[nq] -> Just (nq, Nothing)
_ -> Nothing
gemQuery <- case query of
Just q -> Just <$> unescapeString (T.unpack q)
Nothing -> Just Nothing
(auth, path) <- case T.splitOn "/" noQuery of
[a] -> Just (a, [])
[a, ""] -> Just (a, [])
a:ps -> Just (a, ps)
_ -> Nothing
gemPath <- mapM (unescapeString . T.unpack) path
(host, gemPort) <- case T.splitOn ":" auth of
[h, p] -> case reads $ T.unpack p of
[(n, "")] -> Just (h, Just n)
_ -> Nothing
[h] -> Just (h, Nothing)
_ -> Nothing
let gemHost = T.unpack host
Just GemURL {..}
-- | add required escape sequences to a string
escapeString :: String -> String
escapeString = concatMap
( \n -> let ch = chr $ fromIntegral n in
if ch `elem` unescaped
then [ch]
else '%' : toHex n
) . BSL.unpack . toLazyByteString . stringUtf8
where
unescaped = ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z'] ++ "~-_."
toHex =
( \n -> let
high = n `div` 16
low = n `mod` 16
in [hexDigits !! high, hexDigits !! low]
) . fromIntegral
-- | decode an escaped string back to its original value
unescapeString :: String -> Maybe String
unescapeString str = case decodeUtf8' $ BS.pack $ toBytes str of
Right t -> Just $ T.unpack t
_ -> Nothing
where
toBytes = \case
"" -> []
'%':h:l:sub -> let
h' = toLower h
l' = toLower l
in if h' `elem` hexDigits && l' `elem` hexDigits
then toByte h' l' : toBytes sub
else fromIntegral (ord '%') : toBytes (h : l : sub)
ch:sub ->
BSL.unpack (toLazyByteString $ charUtf8 ch) ++ toBytes sub
toByte h l = toNum h * 16 + toNum l
toNum ch = fst $ fromJust $
find (\x -> snd x == ch) $ zip [0..] hexDigits
hexDigits :: String
hexDigits = ['0'..'9'] ++ ['a'..'f']
--jl

View File

@ -30,6 +30,8 @@ time.
-}
{-# LANGUAGE LambdaCase #-}
module Network.Gemini.Capsule.Internal (
readURL,
sendResponse
@ -37,14 +39,24 @@ module Network.Gemini.Capsule.Internal (
import Data.Connection (Connection)
import Network.Gemini.Capsule.Encoding
import Network.Gemini.Capsule.Types
-- Constants
-- Maximum size to read from a conneciton
inBufSize :: Int
inBufSize = 1026
-- | Reads a 'GemURL' from a 'Connection'
readURL
:: Connection a
-- ^ the connection
-> IO (Maybe GemURL)
readURL = undefined
readURL conn =
strFromConn inBufSize conn >>= \case
Nothing -> return Nothing
Just str -> return $ decodeGemURL str
-- | Sends a 'GemResponse' to a 'Connection'
sendResponse
@ -55,4 +67,15 @@ sendResponse
-> 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
strFromConn
:: Int
-- ^ The maximum number of bytes to read
-> Connection a
-- ^ The connection to read from
-> IO (Maybe String)
strFromConn = undefined
--jl

View File

@ -0,0 +1,146 @@
{-
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.Capsule.EncodingSpec (spec) where
import Test.Hspec (Spec, context, describe, it, shouldBe)
import Network.Gemini.Capsule.Encoding
import Network.Gemini.Capsule.Types
spec :: Spec
spec = describe "Encoding" $ do
encodeGemURLSpec
decodeGemURLSpec
escapeStringSpec
unescapeStringSpec
encodeGemURLSpec :: Spec
encodeGemURLSpec = describe "encodeGemURL" $ mapM_
( \(desc, req, expected) -> context desc $
it ("should be " ++ show expected) $
encodeGemURL req `shouldBe` expected
)
-- description, request, expected
[ ( "simple", simpleURL, simpleExp )
, ( "with port", withPortURL, withPortExp )
, ( "with path", withPathURL, withPathExp )
, ( "with query", withQueryURL, withQueryExp )
, ( "blank query", blankQueryURL, blankQueryExp )
, ( "with escape", withEscapeURL, withEscapeExp )
]
where
simpleURL = newGemURL "example.com"
simpleExp = "gemini://example.com/"
withPortURL = simpleURL { gemPort = Just 1965 }
withPortExp = "gemini://example.com:1965/"
withPathURL = simpleURL { gemPath = ["foo", "bar"] }
withPathExp = "gemini://example.com/foo/bar"
withQueryURL = simpleURL { gemQuery = Just "foo" }
withQueryExp = "gemini://example.com/?foo"
blankQueryURL = simpleURL { gemQuery = Just "" }
blankQueryExp = "gemini://example.com/?"
withEscapeURL = simpleURL
{ gemPath = ["foo bar"]
, gemQuery = Just "baz quux"
}
withEscapeExp = "gemini://example.com/foo%20bar?baz%20quux"
decodeGemURLSpec :: Spec
decodeGemURLSpec = describe "decodeGemURL" $ mapM_
( \(str, expected) -> context (show str) $
it ("should be " ++ show expected) $
decodeGemURL str `shouldBe` expected
)
-- URL string, expected
[ ( simpleStr, Just simpleURL )
, ( withSlashStr, Just simpleURL )
, ( withPathStr, Just withPathURL )
, ( withQueryStr, Just withQueryURL )
, ( pathQueryStr, Just pathQueryURL )
, ( blankQueryStr, Just blankQueryURL )
, ( withFragmentStr, Just simpleURL )
, ( escapedStr, Just escapedURL )
, ( httpStr, Nothing )
, ( malformed, Nothing )
, ( "", Nothing )
]
where
simpleStr = "gemini://example.com"
simpleURL = newGemURL "example.com"
withSlashStr = simpleStr ++ "/"
withPathStr = simpleStr ++ "/foo/bar"
withPathURL = simpleURL { gemPath = ["foo", "bar"] }
withQueryStr = simpleStr ++ "?foo"
withQueryURL = simpleURL { gemQuery = Just "foo" }
pathQueryStr = withPathStr ++ "?baz"
pathQueryURL = withPathURL { gemQuery = Just "baz" }
blankQueryStr = simpleStr ++"?"
blankQueryURL = simpleURL { gemQuery = Just "" }
withFragmentStr = simpleStr ++ "#foo"
escapedStr = simpleStr ++ "/foo%20bar/baz?quux%20stuff"
escapedURL = simpleURL
{ gemPath = ["foo bar", "baz"]
, gemQuery = Just "quux stuff"
}
httpStr = "http://example.com"
malformed = "foo"
escapeStringSpec :: Spec
escapeStringSpec = describe "escapeString" $ mapM_
( \(input, expected) -> context (show input) $
it ("should be " ++ show expected) $
escapeString input `shouldBe` expected
)
-- input, expected
[ ( "~foo-bar_baz.quux", "~foo-bar_baz.quux" )
, ( "foo:/?=&#%", "foo%3a%2f%3f%3d%26%23%25" )
, ( "foo\xe9", "foo%c3%a9" )
]
unescapeStringSpec :: Spec
unescapeStringSpec = describe "unescapeString" $ mapM_
( \(input, expected) -> context (show input) $
it ("should be " ++ show expected) $
unescapeString input `shouldBe` expected
)
-- input, expected
[ ( "foo", Just "foo" )
, ( "foo%20bar", Just "foo bar" )
, ( "foo%7x", Just "foo%7x" )
, ( "foo%a", Just "foo%a" )
, ( "foo%", Just "foo%" )
, ( "foo%c3%a9", Just "foo\xe9" )
, ( "foo%ff", Nothing )
]
--jl

View File

@ -20,11 +20,70 @@ License along with this program. If not, see
-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Gemini.Capsule.InternalSpec (spec) where
import Test.Hspec (Spec, describe)
import qualified Data.ByteString as BS
import Data.Char (ord)
import Data.Connection (Connection (..))
import System.IO.Streams (nullInput, unRead)
import Test.Hspec (Spec, context, describe, shouldReturn, xit)
import Network.Gemini.Capsule.Types
import Network.Gemini.Capsule.Internal
spec :: Spec
spec = describe "Internal" $ return ()
spec = describe "Internal" $ do
readURLSpec
sendResponseSpec
strFromConnSpec
readURLSpec :: Spec
readURLSpec = describe "readURL" $ mapM_
( \(desc, ioConn, expect) -> context desc $
xit ("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 = mkConn "gemini://example.com/\r\n"
longConn = mkConn longBS
tooLongConn = mkConn tooLongBS
gibConn = mkConn "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/"
mkConn bs = do
s <- nullInput
unRead bs s
return sampleConnection { source = s }
sendResponseSpec :: Spec
sendResponseSpec = describe "sendResponse" $ return ()
sampleConnection :: Connection a
sampleConnection = Connection
{ source = undefined
, send = const $ return ()
, close = return ()
, connExtraInfo = undefined
}
strFromConnSpec :: Spec
strFromConnSpec = describe "strFromConn" $ return ()
--jl

View File

@ -22,128 +22,14 @@ License along with this program. If not, see
module Network.Gemini.CapsuleSpec (spec) where
import Test.Hspec (Spec, context, describe, it, shouldBe)
import Test.Hspec (Spec, describe)
import qualified Network.Gemini.Capsule.EncodingSpec as Encoding
import qualified Network.Gemini.Capsule.InternalSpec as Internal
import Network.Gemini.Capsule
import Network.Gemini.Capsule.Types
spec :: Spec
spec = describe "Network.Gemini.Capsule" $ do
Encoding.spec
Internal.spec
encodeGemURLSpec
decodeGemURLSpec
escapeStringSpec
unescapeStringSpec
encodeGemURLSpec :: Spec
encodeGemURLSpec = describe "encodeGemURL" $ mapM_
( \(desc, req, expected) -> context desc $
it ("should be " ++ show expected) $
encodeGemURL req `shouldBe` expected
)
-- description, request, expected
[ ( "simple", simpleURL, simpleExp )
, ( "with port", withPortURL, withPortExp )
, ( "with path", withPathURL, withPathExp )
, ( "with query", withQueryURL, withQueryExp )
, ( "blank query", blankQueryURL, blankQueryExp )
, ( "with escape", withEscapeURL, withEscapeExp )
]
where
simpleURL = newGemURL "example.com"
simpleExp = "gemini://example.com/"
withPortURL = simpleURL { gemPort = Just 1965 }
withPortExp = "gemini://example.com:1965/"
withPathURL = simpleURL { gemPath = ["foo", "bar"] }
withPathExp = "gemini://example.com/foo/bar"
withQueryURL = simpleURL { gemQuery = Just "foo" }
withQueryExp = "gemini://example.com/?foo"
blankQueryURL = simpleURL { gemQuery = Just "" }
blankQueryExp = "gemini://example.com/?"
withEscapeURL = simpleURL
{ gemPath = ["foo bar"]
, gemQuery = Just "baz quux"
}
withEscapeExp = "gemini://example.com/foo%20bar?baz%20quux"
decodeGemURLSpec :: Spec
decodeGemURLSpec = describe "decodeGemURL" $ mapM_
( \(str, expected) -> context (show str) $
it ("should be " ++ show expected) $
decodeGemURL str `shouldBe` expected
)
-- URL string, expected
[ ( simpleStr, Just simpleURL )
, ( withSlashStr, Just simpleURL )
, ( withPathStr, Just withPathURL )
, ( withQueryStr, Just withQueryURL )
, ( pathQueryStr, Just pathQueryURL )
, ( blankQueryStr, Just blankQueryURL )
, ( withFragmentStr, Just simpleURL )
, ( escapedStr, Just escapedURL )
, ( httpStr, Nothing )
, ( malformed, Nothing )
, ( "", Nothing )
]
where
simpleStr = "gemini://example.com"
simpleURL = newGemURL "example.com"
withSlashStr = simpleStr ++ "/"
withPathStr = simpleStr ++ "/foo/bar"
withPathURL = simpleURL { gemPath = ["foo", "bar"] }
withQueryStr = simpleStr ++ "?foo"
withQueryURL = simpleURL { gemQuery = Just "foo" }
pathQueryStr = withPathStr ++ "?baz"
pathQueryURL = withPathURL { gemQuery = Just "baz" }
blankQueryStr = simpleStr ++"?"
blankQueryURL = simpleURL { gemQuery = Just "" }
withFragmentStr = simpleStr ++ "#foo"
escapedStr = simpleStr ++ "/foo%20bar/baz?quux%20stuff"
escapedURL = simpleURL
{ gemPath = ["foo bar", "baz"]
, gemQuery = Just "quux stuff"
}
httpStr = "http://example.com"
malformed = "foo"
escapeStringSpec :: Spec
escapeStringSpec = describe "escapeString" $ mapM_
( \(input, expected) -> context (show input) $
it ("should be " ++ show expected) $
escapeString input `shouldBe` expected
)
-- input, expected
[ ( "~foo-bar_baz.quux", "~foo-bar_baz.quux" )
, ( "foo:/?=&#%", "foo%3a%2f%3f%3d%26%23%25" )
, ( "foo\xe9", "foo%c3%a9" )
]
unescapeStringSpec :: Spec
unescapeStringSpec = describe "unescapeString" $ mapM_
( \(input, expected) -> context (show input) $
it ("should be " ++ show expected) $
unescapeString input `shouldBe` expected
)
-- input, expected
[ ( "foo", Just "foo" )
, ( "foo%20bar", Just "foo bar" )
, ( "foo%7x", Just "foo%7x" )
, ( "foo%a", Just "foo%a" )
, ( "foo%", Just "foo%" )
, ( "foo%c3%a9", Just "foo\xe9" )
, ( "foo%ff", Nothing )
]
--jl