0 | module Qutescript.Request

  2 | import Control.RIO

  3 | import Control.RIO.App

  4 | import Control.RIO.File

  5 | import Data.FilePath.File

  6 | import Data.Maybe

  7 | import Derive.Prelude

  8 | import System

 10 | %default total

 11 | %language ElabReflection

 17 | public export

 18 | data QuteError : Type where

 19 |   UnsetEnvironment : (var : String) -> QuteError

 20 |   InvalidMode      : (var,val : String) -> QuteError

 21 |   InvalidFile      : (var,val : String) -> QuteError

 22 |   InvalidPath      : (var,val : String) -> QuteError

 23 |   InvalidNat       : (var,val : String) -> QuteError

 25 | public export

 26 | data QuteMode = Hints | Command

 28 | %runElab derive "QuteMode" [Show,Eq,Ord]

 30 | public export

 31 | record CommandData where

 32 |   constructor C

 33 |   url          : String

 34 |   title        : String

 35 |   tabIndex     : Nat

 36 |   count        : Maybe Nat

 37 |   selectedText : Maybe String

 39 | public export

 40 | record HintData where

 41 |   constructor H

 42 |   url          : String

 43 |   currentUrl   : String

 44 |   selectedText : Maybe String

 45 |   selectedHtml : Maybe String

 47 | public export

 48 | 0 ModeData : QuteMode -> Type

 49 | ModeData Hints   = HintData

 50 | ModeData Command = CommandData

 52 | public export

 53 | record Request where

 54 |   [noHints]

 55 |   constructor R

 56 |   mode            : QuteMode

 57 |   userAgent       : Maybe String

 58 |   fifo            : File Abs

 59 |   html            : File Abs

 60 |   text            : File Abs

 61 |   configDir       : Path Abs

 62 |   dataDir         : Path Abs

 63 |   downloadDir     : Path Abs

 64 |   commandlineText : Maybe String

 65 |   version         : String

 66 |   otherData       : ModeData mode

 72 | mode : (var,val : String) -> Either QuteError QuteMode

 73 | mode _ "hints"   = Right Hints

 74 | mode _ "command" = Right Command

 75 | mode v s         = Left (InvalidMode v s)

 77 | nat : (var,val : String) -> Either QuteError Nat

 78 | nat _ "0" = Right 0

 79 | nat v s   = case cast {to = Nat} s of

 80 |   0 => Left (InvalidNat v s)

 81 |   n => Right n

 83 | file : (var,val : String) -> Either QuteError (File Abs)

 84 | file v s = maybe (Left $ InvalidFile v s) Right $ parse s

 86 | path : (var,val : String) -> Either QuteError (Path Abs)

 87 | path v s = maybe (Left $ InvalidPath v s) Right $ parse s

 89 | string : (var,val : String) -> Either QuteError String

 90 | string _ v = Right v

 92 | parameters {0 ts : List Type}

 93 |            {auto has : Has QuteError ts}

 95 |   readEnv :

 96 |        ((var,val : String) -> Either QuteError a)

 97 |     -> String

 98 |     -> App ts a

 99 |   readEnv f var = do

100 |     Just str <- getEnv var | Nothing => throw (UnsetEnvironment var)

101 |     injectEither (f var str)

103 |   readOptEnv :

104 |        ((var,val : String) -> Either QuteError a)

105 |     -> String

106 |     -> App ts (Maybe a)

107 |   readOptEnv f var = do

108 |     Just str <- getEnv var | Nothing => pure Nothing

109 |     injectEither (Just <$> f var str)

111 |   commandData : App ts CommandData

112 |   commandData =

113 |     [| C

114 |          (readEnv string "QUTE_URL")

115 |          (readEnv string "QUTE_TITLE")

116 |          (readEnv nat "QUTE_TAB_INDEX")

117 |          (readOptEnv nat "QUTE_COUNT")

118 |          (readOptEnv string "QUTE_SELECTED_TEXT")

119 |     |]

121 |   hintData : App ts HintData

122 |   hintData =

123 |     [| H

124 |          (readEnv string "QUTE_URL")

125 |          (readEnv string "QUTE_CURRENT_URL")

126 |          (readOptEnv string "QUTE_SELECTED_TEXT")

127 |          (readOptEnv string "QUTE_SELECTED_HTML")

128 |     |]

130 |   otherData : (m : QuteMode) -> App ts (ModeData m)

131 |   otherData Hints   = hintData

132 |   otherData Command = commandData

134 |   export

135 |   request : App ts Request

136 |   request = do

137 |     m   <- readEnv mode "QUTE_MODE"

138 |     ua  <- readOptEnv string "QUTE_USER_AGENT"

139 |     fi  <- readEnv file "QUTE_FIFO"

140 |     ht  <- readEnv file "QUTE_HTML"

141 |     te  <- readEnv file "QUTE_TEXT"

142 |     cd  <- readEnv path "QUTE_CONFIG_DIR"

143 |     dad <- readEnv path "QUTE_DATA_DIR"

144 |     dod <- readEnv path "QUTE_DOWNLOAD_DIR"

145 |     cot <- readOptEnv string "QUTE_COMMANDLINE_TEXT"

146 |     v   <- readEnv string "QUTE_VERSION"

147 |     o   <- otherData m

148 |     pure $ R m ua fi ht te cd dad dod cot v o

154 | hintPairs : HintData -> List (String,String)

155 | hintPairs (H u cu st sh) =

156 |   [ ("QUTE_URL", u)

157 |   , ("QUTE_CURRENT_URL", cu)

158 |   , ("QUTE_SELECTED_TEXT", fromMaybe "" st)

159 |   , ("QUTE_SELECTED_HTML", fromMaybe "" sh)

160 |   ]

162 | commandPairs : CommandData -> List (String,String)

163 | commandPairs (C u t ti c st) =

164 |   [ ("QUTE_URL", u)

165 |   , ("QUTE_TITLE", t)

166 |   , ("QUTE_TAB_INDEX", show ti)

167 |   , ("QUTE_COUNT", show c)

168 |   , ("QUTE_SELECTED_TEXT", fromMaybe "" st)

169 |   ]

171 | modePairs : (m : QuteMode) -> ModeData m -> List (String,String)

172 | modePairs Hints   = hintPairs

173 | modePairs Command = commandPairs

176 | pairs : Request -> List (String,String)

177 | pairs (R m ua fi ht te cd dad dod cot v o) =

178 |   [ ("QUTE_MODE", show m)

179 |   , ("QUTE_USER_AGENT", fromMaybe "" ua)

180 |   , ("QUTE_FIFO", interpolate fi)

181 |   , ("QUTE_HTML", interpolate ht)

182 |   , ("QUTE_TEXT", interpolate te)

183 |   , ("QUTE_CONFIG_DIR", interpolate cd)

184 |   , ("QUTE_DATA_DIR", interpolate dad)

185 |   , ("QUTE_DOWNLOAD_DIR", interpolate dod)

186 |   , ("QUTE_COMMANDLINE_TEXT", fromMaybe "" cot)

187 |   , ("QUTE_VERSION", v)

188 |   ] ++ modePairs m o

195 | printErr : QuteError -> String

196 | printErr (UnsetEnvironment s) = "Environment variable not set: \{s}"

197 | printErr (InvalidMode v s)    = "\{v}: Invalid mode: \{s}"

198 | printErr (InvalidFile v s)    = "\{v}: Invalid file path: \{s}"

199 | printErr (InvalidPath v s)    = "\{v}: Invalid directory: \{s}"

200 | printErr (InvalidNat v s)     = "\{v}: Not a natural number: \{s}"

202 | export %inline

203 | quteRun : All (\x => x -> String) ts -> App ts () -> IO ()

204 | quteRun = runApp . mapProperty (die .)