0 | module IO.Async.Console
  1 |
  2 | import Control.Monad.Resource
  3 | import Data.ByteString
  4 | import Data.String
  5 | import IO.Async.Core
  6 | import IO.Async.Logging
  7 | import IO.Async.Service
  8 | import System.Posix.File.Prim
  9 | import Text.ANSI
 10 |
 11 | %default total
 12 |
 13 | ||| Record representing a console with
 14 | ||| standard output and error output
 15 | public export
 16 | record ConsoleOut (0 e : Type) where
 17 |   constructor MkConsoleOut
 18 |   close_       : Async e [] ()
 19 |   putBytes_    : ByteString -> Async e [] ()
 20 |   putErrBytes_ : ByteString -> Async e [] ()
 21 |
 22 | export %inline
 23 | Resource (Async e) (ConsoleOut e) where cleanup = close_
 24 |
 25 | parameters {default 100 capacity : Nat}
 26 |
 27 |   ||| Creates a console for writing messages and errors to.
 28 |   |||
 29 |   ||| To make this available to many fibers, this is run as a service
 30 |   ||| in the background using an internal buffer that can hold up to
 31 |   ||| `capacity` messages.
 32 |   export covering
 33 |   console :
 34 |        (putstr, puterr : ByteString -> Async e [] ())
 35 |     -> Async e es (ConsoleOut e)
 36 |   console putstr puterr = do
 37 |     srv <- stateless (const ()) putPair
 38 |     pure $ MkConsoleOut (cleanup srv) (send srv . (True,)) (send srv . (False,))
 39 |
 40 |     where
 41 |       putPair : (Bool,ByteString) -> Async e [] ()
 42 |       putPair (True,s)  = putstr s
 43 |       putPair (False,s) = puterr s
 44 |
 45 |   ||| The default console, printing to standard out and standard err.
 46 |   |||
 47 |   ||| Note: Since many fibers might be writing to the console at the same
 48 |   |||       this uses a bounded channel with a buffer of the given
 49 |   |||       capacity internally.
 50 |   export covering
 51 |   stdOut : Async e es (ConsoleOut e)
 52 |   stdOut =
 53 |     console
 54 |       (\bs => primIO $ Errno.ignore $ fwrite {es = [Errno]} Stdout bs)
 55 |       (\bs => primIO $ Errno.ignore $ fwrite {es = [Errno]} Stderr bs)
 56 |
 57 | parameters {auto con : ConsoleOut e}
 58 |
 59 |   ||| Put a bytestring to the console's standard output.
 60 |   export
 61 |   cputBytes : ByteString -> Async e es ()
 62 |   cputBytes s = weakenErrors $ con.putBytes_ s
 63 |
 64 |   ||| Put a string to the console's standard output.
 65 |   export %inline
 66 |   cputStr : String -> Async e es ()
 67 |   cputStr = cputBytes . fromString
 68 |   
 69 |   ||| Put a string plus trailing line break
 70 |   ||| to the console's standard output.
 71 |   export %inline
 72 |   cputStrLn : String -> Async e es ()
 73 |   cputStrLn s = cputStr $ s ++ "\n"
 74 |   
 75 |   ||| Print a value to the console's standard output.
 76 |   export %inline
 77 |   cprint : Show a => a -> Async e es ()
 78 |   cprint = cputStr . show
 79 |   
 80 |   ||| Print a value plus trailing lne break
 81 |   ||| to the console's standard output.
 82 |   export %inline
 83 |   cprintLn : Show a => a -> Async e es ()
 84 |   cprintLn = cputStrLn . show
 85 |
 86 |   ||| Put a bytestring to the console's error output.
 87 |   export
 88 |   cputErrBytes : ByteString -> Async e es ()
 89 |   cputErrBytes s = weakenErrors $ con.putErrBytes_ s
 90 |   
 91 |   ||| Put a string to the console's error output.
 92 |   export %inline
 93 |   cputErr : String -> Async e es ()
 94 |   cputErr = cputErrBytes . fromString
 95 |   
 96 |   ||| Put a string plus trailing line break
 97 |   ||| to the console's error output.
 98 |   export %inline
 99 |   cputErrLn : String -> Async e es ()
100 |   cputErrLn s = cputErr $ s ++ "\n"
101 |   
102 |   ||| Print a value to the console's error output.
103 |   export %inline
104 |   cprintErr : Show a => a -> Async e es ()
105 |   cprintErr = cputErr . show
106 |   
107 |   ||| Print a value plus trailing lne break
108 |   ||| to the console's error output.
109 |   export %inline
110 |   cprintErrLn : Show a => a -> Async e es ()
111 |   cprintErrLn = cputErrLn . show
112 |
113 | --------------------------------------------------------------------------------
114 | -- Console Logging
115 | --------------------------------------------------------------------------------
116 |
117 | export
118 | consoleLogger :
119 |      ConsoleOut e
120 |   -> (LogLevel -> List String -> List String)
121 |   -> Logger e
122 | consoleLogger c f =
123 |   MkLogger $ \l,ss => case l of
124 |     Error => cputErr (unlines $ f l ss)
125 |     Fatal => cputErr (unlines $ f l ss)
126 |     _     => cputStr (unlines $ f l ss)
127 |
128 | export
129 | basicConsoleLogger : ConsoleOut e -> Logger e
130 | basicConsoleLogger c =
131 |   consoleLogger c $ \l => map $ \s => "[\{l}] \{s}"
132 |
133 | col : LogLevel -> String
134 | col Trace = show $ colored White "trace"
135 | col Debug = show $ colored Cyan "debug"
136 | col Info  = show $ colored Green "info"
137 | col Warn  = show $ colored Yellow "warn"
138 | col Error = show $ colored Red "error"
139 | col Fatal = show $ colored Red "fatal"
140 |
141 | space : LogLevel -> String
142 | space Trace = " "
143 | space Debug = " "
144 | space Info  = "  "
145 | space Warn  = "  "
146 | space Error = " "
147 | space Fatal = " "
148 |
149 | ||| A console logger with colored log level tags
150 | export
151 | colorConsoleLogger : ConsoleOut e -> Logger e
152 | colorConsoleLogger c =
153 |   consoleLogger c $ \l => map $ \s => "[\{col l}]\{space l}\{s}"
154 |
155 | --------------------------------------------------------------------------------
156 | --          Syslog
157 | --------------------------------------------------------------------------------
158 |
159 | severity : LogLevel -> Nat
160 | severity Trace   = 7
161 | severity Debug   = 7
162 | severity Info    = 6
163 | severity Warn    = 5
164 | severity Error   = 4
165 | severity Fatal   = 3
166 |
167 | ||| A logger using syslog priority codes. This can be used with
168 | ||| systemd services.
169 | export
170 | syslogLogger : ConsoleOut e -> Logger e
171 | syslogLogger c =
172 |   consoleLogger c $ \l => map $ \s => "<\{show $ severity l}> \{s}"
173 |