From 9110064fe62f98dd3ecc5fb4c3915a843492b8fb Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 23 Oct 2023 23:18:34 +0200
Subject: a year went by

This does many meta-things, but changes no functionality:
 - get rid of stack, and use just cabal with a stackage snapshot instead
   (why did I ever think stack was a good idea?)
 - update the stackage snapshot to something halfway recent
 - thus making builds work on nixpkgs-23.05 (current stable)
 - separating out packages into their own cabal files
 - use the GHC2021 set of extensions as default
 - very slight code changes to make things build again
 - update readme accordingly
 - stylish-haskell run
---
 lib/Uris.hs | 106 ------------------------------------------------------------
 1 file changed, 106 deletions(-)
 delete mode 100644 lib/Uris.hs

(limited to 'lib/Uris.hs')

diff --git a/lib/Uris.hs b/lib/Uris.hs
deleted file mode 100644
index 127b7f1..0000000
--- a/lib/Uris.hs
+++ /dev/null
@@ -1,106 +0,0 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TypeApplications  #-}
-
--- | Functions to deal with uris and custom uri schemes
-module Uris where
-
-import           Universum
-
-import           Data.Aeson         (FromJSON (..), Options (..),
-                                     SumEncoding (UntaggedValue),
-                                     defaultOptions, genericParseJSON)
-import qualified Data.Map.Strict    as M
-import qualified Data.Text          as T
-import           GHC.TypeLits       (KnownSymbol, symbolVal)
-import           Network.URI        (URI (..), URIAuth (..), parseURI,
-                                     uriToString)
-import qualified Network.URI.Encode as URI
-
-data Substitution =
-    Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
-  | DomainSubstitution { substs :: Map Text Text, scope :: [String] }
-  | Allowed  { scope :: [String], allowed :: [Text] }
-  | Unrestricted { scope :: [String] }
-  deriving (Generic, Show, NFData)
-
-
-instance FromJSON Substitution where
-  parseJSON = genericParseJSON defaultOptions
-    { sumEncoding = UntaggedValue
-    , rejectUnknownFields = True
-    }
-
-type SchemaSet = Map Text [Substitution]
-
-
--- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...],
--- and a normalised version of the same URI
-parseUri :: Text -> Maybe (Text, Text, Text, Text)
-parseUri raw =
-  case parseURI (toString (T.strip raw)) of
-    Nothing -> Nothing
-    Just uri@URI{..} -> case uriAuthority of
-        Nothing -> Nothing
-        Just URIAuth {..} -> Just
-          ( fromString uriScheme
-          , fromString $ uriUserInfo <> uriRegName <> uriPort
-          , fromString $ uriPath <> uriQuery <> uriFragment
-          , fromString $ uriToString id uri ""
-          )
-
-
-data SubstError =
-    SchemaDoesNotExist Text
-  | NotALink
-  | DomainDoesNotExist Text
-  | IsBlocked
-  | DomainIsBlocked [Text]
-  | VarsDisallowed
-  | WrongScope Text [Text]
-  -- ^ This link's schema exists, but cannot be used in this scope.
-  -- The second field contains a list of schemas that may be used instead.
-  deriving (Eq, Ord) -- errors are ordered so we can show more specific ones
-
-
-applySubsts :: KnownSymbol s
-  => Proxy s -> SchemaSet -> Text -> Either SubstError Text
-applySubsts s substs uri =  do
-  when (T.isInfixOf "{{" uri || T.isInfixOf "}}" uri)
-   $ Left VarsDisallowed
-  parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri
-
-  let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs
-
-  case nonEmpty $ map (applySubst parts) rules of
-    Nothing     -> Left (SchemaDoesNotExist schema)
-    Just result -> minimum result
-  where
-    thisScope = symbolVal s
-    applySubst (schema, domain, rest, uri) rule = do
-
-      -- is this scope applicable?
-      unless (symbolVal s `elem` scope rule)
-        $ Left (WrongScope schema
-                 $ map fst -- make list of available uri schemes
-                 . filter (any (elem thisScope . scope) . snd)
-                 $ toPairs substs)
-
-      case rule of
-        DomainSubstitution table _  -> do
-          prefix <- case M.lookup domain table of
-            Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain))
-            Just a  -> Right a
-          pure (prefix <> rest)
-        Prefixed {..}
-          | domain `elem` blocked -> Left IsBlocked
-          | domain `elem` allowed -> Right uri
-          | otherwise -> Right (prefix <> URI.encodeText uri)
-        Allowed _ allowlist
-          | domain `elem` allowlist -> Right uri
-          | otherwise -> Left (DomainIsBlocked allowlist)
-        Unrestricted _ -> Right uri
-- 
cgit v1.2.3