@@ -0,0 +1,116 @@
1+{-# LANGUAGE TypeApplications #-}
2+{-# LANGUAGE PatternGuards #-}
3+{-# LANGUAGE OverloadedStrings #-}
5+module Obelisk.Configs.Internal.Environment where
7+import Control.Applicative
9+import qualified Data.Attoparsec.ByteString as P
10+import qualified Data.Attoparsec.ByteString.Char8 as P (hexadecimal)
11+import qualified Data.Attoparsec.Combinator as P
12+import Data.Bifunctor (second)
13+import Data.ByteString (ByteString)
14+import qualified Data.ByteString as BS
15+import qualified Data.ByteString.Base64 as Base64
16+import qualified Data.ByteString.Builder as Builder
17+import qualified Data.ByteString.Char8 as Char8
18+import qualified Data.ByteString.Lazy as LBS
19+import qualified Data.Char as Char
21+import qualified Data.Map as Map
22+import Data.Text (Text)
23+import qualified Data.Text as T
24+import qualified Data.Text.Lazy as LT
25+import Data.Tuple (swap)
26+import Data.Witherable
28+import System.Environment
29+import qualified Text.Printf as Printf
35+ deriving (Eq, Ord, Show)
37+envVarEscapes :: [(Char, Word8)]
38+envVarEscapes = fmap (second f)
45+ f = fromIntegral . Char.ord
47+escapeVarName :: EnvCodec -> Text -> ByteString
48+escapeVarName codec x = LBS.toStrict . Builder.toLazyByteString $ T.foldr ((<>) . f) mempty x <> codec'
50+ escapeCode = Map.fromList envVarEscapes
52+ codec' = case codec of
53+ EnvCodec_Base64 -> "__base64"
56+ f :: Char -> Builder.Builder
58+ | not (Char.isAscii c) = error "bad"
60+ | Char.isAlphaNum c = Builder.char7 c
61+ | Just c' <- Map.lookup c escapeCode = "__" <> Builder.word8 c'
62+ | otherwise = "__x" <> (Builder.string7 $ Printf.formatInt (Char.ord c) (Printf.FieldFormat (Just 2) Nothing (Just Printf.ZeroPad) Nothing False "" 'x') "")
64+unescapeVarName :: ByteString -> Either String (Text, EnvCodec)
65+unescapeVarName x = P.parseOnly ((,) <$> fileName <*> codec <* P.endOfInput) x
67+ escapeCode = Map.fromList $ fmap swap envVarEscapes
69+ codec :: P.Parser EnvCodec
70+ codec = P.option EnvCodec_Char8 $ (EnvCodec_Base64 <$ "__base64")
72+ -- | parse ps. succeed only if both ps and qs succeeds
73+ guardLookahead ps qs = do
81+ case Map.lookup c escapeCode of
83+ Just c' -> return c')
84+ ) <|> ( "__x" *> (Char.chr . fromIntegral <$> P.hexadecimal @Word8))
86+ parseEnvChar = Char.chr . fromIntegral <$> P.satisfy (P.inClass "a-zA-Z0-9")
88+ fileName = LT.toStrict . LT.pack <$> P.many' (P.choice
91+ , guardLookahead ('/' <$ "_") (parseEnvChar <|> parseEscapeCode)
95+getConfigsFromEnvironment :: ByteString -> Map Text ByteString -> IO (Map Text ByteString)
96+getConfigsFromEnvironment varNamePrefix dirConfigs = do
98+ prefix needle haystack
99+ | needle `BS.isPrefixOf` haystack = Just (BS.drop (BS.length needle) haystack)
100+ | otherwise = Nothing
102+ makeEnv (k0, v0) = case prefix varNamePrefix (Char8.pack k0) of
103+ Nothing -> return Nothing
104+ Just k -> case unescapeVarName k of
105+ Left bad -> error bad
106+ Right (k', codec) ->
109+ EnvCodec_Char8 -> Char8.pack v0
110+ EnvCodec_Base64 -> Base64.decodeLenient (Char8.pack v0)
111+ in case Map.lookup k' dirConfigs of
112+ Just v' | v /= v' -> error $ "conflicting obelisk config: env " <> k0 <> " /= ./config/" <> (T.unpack k')
113+ _ -> return (Just (k', v))
115+ env <- wither makeEnv =<< getEnvironment
116+ return $ (Map.fromList env) <> dirConfigs