implemented basic logic for readURL
This commit is contained in:
parent
893ab49256
commit
5c83bf3123
|
@ -24,6 +24,7 @@ extra-source-files:
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Network.Gemini.Capsule
|
Network.Gemini.Capsule
|
||||||
|
Network.Gemini.Capsule.Encoding
|
||||||
Network.Gemini.Capsule.Internal
|
Network.Gemini.Capsule.Internal
|
||||||
Network.Gemini.Capsule.Types
|
Network.Gemini.Capsule.Types
|
||||||
other-modules:
|
other-modules:
|
||||||
|
@ -34,6 +35,7 @@ library
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
base >=4.7 && <5
|
||||||
, bytestring >=0.10.12.0 && <0.11
|
, bytestring >=0.10.12.0 && <0.11
|
||||||
|
, io-streams
|
||||||
, network
|
, network
|
||||||
, tcp-streams >=1.0.1.1 && <1.1
|
, tcp-streams >=1.0.1.1 && <1.1
|
||||||
, text >=1.2.4.1 && <1.3
|
, text >=1.2.4.1 && <1.3
|
||||||
|
@ -46,6 +48,7 @@ test-suite gemcap-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Network.Gemini.Capsule.EncodingSpec
|
||||||
Network.Gemini.Capsule.InternalSpec
|
Network.Gemini.Capsule.InternalSpec
|
||||||
Network.Gemini.CapsuleSpec
|
Network.Gemini.CapsuleSpec
|
||||||
Paths_gemcap
|
Paths_gemcap
|
||||||
|
@ -57,6 +60,7 @@ test-suite gemcap-test
|
||||||
, bytestring >=0.10.12.0 && <0.11
|
, bytestring >=0.10.12.0 && <0.11
|
||||||
, gemcap
|
, gemcap
|
||||||
, hspec >=2.7.10 && <2.8
|
, hspec >=2.7.10 && <2.8
|
||||||
|
, io-streams
|
||||||
, network
|
, network
|
||||||
, tcp-streams >=1.0.1.1 && <1.1
|
, tcp-streams >=1.0.1.1 && <1.1
|
||||||
, text >=1.2.4.1 && <1.3
|
, text >=1.2.4.1 && <1.3
|
||||||
|
|
|
@ -28,6 +28,7 @@ dependencies:
|
||||||
- bytestring >= 0.10.12.0 && < 0.11
|
- bytestring >= 0.10.12.0 && < 0.11
|
||||||
- tcp-streams >= 1.0.1.1 && < 1.1
|
- tcp-streams >= 1.0.1.1 && < 1.1
|
||||||
- text >= 1.2.4.1 && < 1.3
|
- text >= 1.2.4.1 && < 1.3
|
||||||
|
- io-streams
|
||||||
- network
|
- network
|
||||||
- tls
|
- tls
|
||||||
- x509
|
- x509
|
||||||
|
|
|
@ -24,36 +24,18 @@ License along with this program. If not, see
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE
|
{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}
|
||||||
LambdaCase,
|
|
||||||
OverloadedStrings,
|
|
||||||
ScopedTypeVariables,
|
|
||||||
RecordWildCards #-}
|
|
||||||
|
|
||||||
module Network.Gemini.Capsule (
|
module Network.Gemini.Capsule (
|
||||||
-- * Running a Gemini Server
|
runGemCapsule
|
||||||
runGemCapsule,
|
|
||||||
-- * Encoding/Decoding Functions
|
|
||||||
encodeGemURL,
|
|
||||||
decodeGemURL,
|
|
||||||
escapeString,
|
|
||||||
unescapeString
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Concurrent (forkIO)
|
import Control.Concurrent (forkIO)
|
||||||
import Control.Exception (IOException, try)
|
import Control.Exception (IOException, try)
|
||||||
import Control.Exception.Base (bracket, finally)
|
import Control.Exception.Base (bracket, finally)
|
||||||
import Control.Monad (void)
|
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 qualified Data.Connection as C
|
||||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
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.TLSSetting (makeServerParams)
|
||||||
import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
|
import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
|
||||||
import qualified Network.Socket as S
|
import qualified Network.Socket as S
|
||||||
|
@ -85,106 +67,13 @@ runGemCapsule settings handler = bracket
|
||||||
listenLoop sock params handler
|
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 :: S.Socket -> ServerParams -> GemHandler -> IO a
|
||||||
listenLoop sock params handler = do
|
listenLoop sock params handler = do
|
||||||
certRef <- newIORef Nothing
|
certRef <- newIORef Nothing
|
||||||
let params' = adjustServerParams certRef params
|
let params' = adjustServerParams certRef params
|
||||||
try (accept params' sock) >>= \case
|
try (accept params' sock) >>= \case
|
||||||
Left (_ :: IOException) -> return ()
|
Left (_::IOException) -> return ()
|
||||||
Right conn -> void $ forkIO $ finally
|
Right conn -> void $ forkIO $ finally
|
||||||
(readIORef certRef >>= runConnection conn handler)
|
(readIORef certRef >>= runConnection conn handler)
|
||||||
(C.close conn)
|
(C.close conn)
|
||||||
listenLoop sock params handler
|
listenLoop sock params handler
|
||||||
|
@ -222,7 +111,4 @@ runConnection conn handler mCert =
|
||||||
Just url -> handler (newGemRequest url) { reqCert = mCert }
|
Just url -> handler (newGemRequest url) { reqCert = mCert }
|
||||||
) >>= sendResponse conn
|
) >>= sendResponse conn
|
||||||
|
|
||||||
hexDigits :: String
|
|
||||||
hexDigits = ['0'..'9'] ++ ['a'..'f']
|
|
||||||
|
|
||||||
--jl
|
--jl
|
||||||
|
|
|
@ -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
|
|
@ -30,6 +30,8 @@ time.
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
|
||||||
module Network.Gemini.Capsule.Internal (
|
module Network.Gemini.Capsule.Internal (
|
||||||
readURL,
|
readURL,
|
||||||
sendResponse
|
sendResponse
|
||||||
|
@ -37,14 +39,24 @@ module Network.Gemini.Capsule.Internal (
|
||||||
|
|
||||||
import Data.Connection (Connection)
|
import Data.Connection (Connection)
|
||||||
|
|
||||||
|
import Network.Gemini.Capsule.Encoding
|
||||||
import Network.Gemini.Capsule.Types
|
import Network.Gemini.Capsule.Types
|
||||||
|
|
||||||
|
-- Constants
|
||||||
|
|
||||||
|
-- Maximum size to read from a conneciton
|
||||||
|
inBufSize :: Int
|
||||||
|
inBufSize = 1026
|
||||||
|
|
||||||
-- | Reads a 'GemURL' from a 'Connection'
|
-- | Reads a 'GemURL' from a 'Connection'
|
||||||
readURL
|
readURL
|
||||||
:: Connection a
|
:: Connection a
|
||||||
-- ^ the connection
|
-- ^ the connection
|
||||||
-> IO (Maybe GemURL)
|
-> 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'
|
-- | Sends a 'GemResponse' to a 'Connection'
|
||||||
sendResponse
|
sendResponse
|
||||||
|
@ -55,4 +67,15 @@ sendResponse
|
||||||
-> IO ()
|
-> IO ()
|
||||||
sendResponse = undefined
|
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
|
--jl
|
||||||
|
|
|
@ -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
|
|
@ -20,11 +20,70 @@ License along with this program. If not, see
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Network.Gemini.Capsule.InternalSpec (spec) where
|
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 :: 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
|
--jl
|
||||||
|
|
|
@ -22,128 +22,14 @@ License along with this program. If not, see
|
||||||
|
|
||||||
module Network.Gemini.CapsuleSpec (spec) where
|
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 qualified Network.Gemini.Capsule.InternalSpec as Internal
|
||||||
|
|
||||||
import Network.Gemini.Capsule
|
|
||||||
import Network.Gemini.Capsule.Types
|
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = describe "Network.Gemini.Capsule" $ do
|
spec = describe "Network.Gemini.Capsule" $ do
|
||||||
|
Encoding.spec
|
||||||
Internal.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
|
--jl
|
||||||
|
|
Loading…
Reference in New Issue
Block a user