├── .gitignore ├── LICENSE ├── README.md ├── examples └── MessageBoard │ ├── Main.idr │ ├── Makefile │ └── db.sql ├── idris_web.ipkg ├── paper ├── conclusion.tex ├── effects.tex ├── forms.tex ├── introduction.tex ├── main.tex ├── messageboard.tex ├── protocols.tex ├── refs.bib └── sigplanconf.cls └── src ├── IdrisWeb ├── CGI │ ├── Cgi.idr │ ├── CgiTypes.idr │ ├── CgiUtils.idr │ ├── formhello.idr │ ├── helloworld.idr │ └── test.idr ├── Common │ ├── Date.idr │ ├── Parser.idr │ └── Random │ │ ├── Makefile │ │ └── RandC.idr ├── DB │ └── SQLite │ │ ├── SQLiteCodes.idr │ │ ├── SQLiteNew.idr │ │ └── SQLiteTest.idr ├── Form │ ├── FormTest.idr │ ├── FormTypes.idr │ └── frmtest.idr ├── GCrypt │ ├── GCrypt.idr │ ├── gcrypt_idr.c │ └── gcrypt_idr.h └── Session │ ├── Session.idr │ ├── SessionUtils.idr │ └── sessiondb.sql ├── MakefileC ├── rand_c.c ├── rand_c.h ├── sqlite3api.c └── sqlite3api.h /.gitignore: -------------------------------------------------------------------------------- 1 | *.ibc 2 | *.o 3 | *.swp 4 | *.db 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Simon Fowler 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | IdrisWeb 2 | ======== 3 | 4 | A secure web framework, built in the Idris language. 5 | -------------------------------------------------------------------------------- /examples/MessageBoard/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | import Effects 3 | import IdrisWeb.CGI.Cgi 4 | import IdrisWeb.Session.Session 5 | import IdrisWeb.Session.SessionUtils 6 | import IdrisWeb.DB.SQLite.SQLiteNew 7 | 8 | ThreadID : Type 9 | ThreadID = Int 10 | 11 | DB_NAME : String 12 | DB_NAME = "/tmp/messageboard.db" 13 | 14 | UserID : Type 15 | UserID = Int 16 | 17 | USERID_VAR : String 18 | USERID_VAR = "user_id" 19 | 20 | ---------- 21 | -- Handler info 22 | ---------- 23 | handleRegisterForm : Maybe String -> Maybe String -> FormHandler [CGI (InitialisedCGI TaskRunning), 24 | SESSION (SessionRes SessionUninitialised), 25 | SQLITE () 26 | ] 27 | 28 | handlePost : Maybe Int -> Maybe String -> FormHandler [CGI (InitialisedCGI TaskRunning), 29 | SESSION (SessionRes SessionUninitialised), 30 | SQLITE () 31 | ] 32 | 33 | handleNewThread : Maybe String -> Maybe String -> FormHandler [CGI (InitialisedCGI TaskRunning), 34 | SESSION (SessionRes SessionUninitialised), 35 | SQLITE () 36 | ] 37 | 38 | handleLoginForm : Maybe String -> Maybe String -> FormHandler [CGI (InitialisedCGI TaskRunning), 39 | SESSION (SessionRes SessionUninitialised), 40 | SQLITE () 41 | ] 42 | 43 | handlers : HandlerList 44 | handlers = [(([FormString, FormString], [CgiEffect, SessionEffect, SqliteEffect]) ** (handleRegisterForm, "handleRegisterForm")), 45 | (([FormString, FormString], [CgiEffect, SessionEffect, SqliteEffect]) ** (handleLoginForm, "handleLoginForm")), 46 | (([FormString, FormString], [CgiEffect, SessionEffect, SqliteEffect]) ** (handleNewThread, "handleNewThread")), 47 | (([FormInt, FormString], [CgiEffect, SessionEffect, SqliteEffect]) ** (handlePost, "handlePost"))] 48 | 49 | 50 | -- Template system would be nice... 51 | htmlPreamble : String 52 | htmlPreamble = "IdrisWeb Message Board" 53 | 54 | htmlPostamble : String 55 | htmlPostamble = "" 56 | 57 | notLoggedIn : EffM IO [CGI (InitialisedCGI TaskRunning), 58 | SESSION (SessionRes SessionInitialised), 59 | SQLITE ()] 60 | [CGI (InitialisedCGI TaskRunning), 61 | SESSION (SessionRes SessionUninitialised), 62 | SQLITE ()] () 63 | notLoggedIn = do output htmlPreamble 64 | output "

Error


You must be logged in to do that!" 65 | output htmlPostamble 66 | discardSession 67 | 68 | outputWithPreamble : String -> Eff IO [CGI (InitialisedCGI TaskRunning)] () 69 | outputWithPreamble txt = do output htmlPreamble 70 | output txt 71 | output htmlPostamble 72 | ----------- 73 | -- Post Creation 74 | ----------- 75 | postInsert : Int -> Int -> String -> Eff IO [SQLITE ()] Bool 76 | postInsert uid thread_id content = do 77 | conn_res <- openDB DB_NAME 78 | if_valid then do 79 | let sql = "INSERT INTO `Posts` (`UserID`, `ThreadID`, `Content`) VALUES (?, ?, ?)" 80 | ps_res <- prepareStatement sql 81 | if_valid then do 82 | bindInt 1 uid 83 | bindInt 2 thread_id 84 | bindText 3 content 85 | bind_res <- finishBind 86 | if_valid then do 87 | executeStatement 88 | finalise 89 | closeDB 90 | return True 91 | else do 92 | cleanupBindFail 93 | return False 94 | else do 95 | cleanupPSFail 96 | return False 97 | else 98 | return False 99 | 100 | 101 | 102 | addPostToDB : Int -> String -> SessionData -> EffM IO [CGI (InitialisedCGI TaskRunning), 103 | SESSION (SessionRes SessionInitialised), 104 | SQLITE ()] 105 | [CGI (InitialisedCGI TaskRunning), 106 | SESSION (SessionRes SessionUninitialised), 107 | SQLITE ()] () 108 | addPostToDB thread_id content sd = do 109 | -- TODO: would be nice to abstract this out 110 | case lookup USERID_VAR sd of 111 | Just (SInt uid) => do insert_res <- postInsert uid thread_id content 112 | if insert_res then do 113 | -- TODO: redirection would be nice 114 | outputWithPreamble "Post successful" 115 | discardSession 116 | return () 117 | else do 118 | outputWithPreamble "There was an error adding the post to the database." 119 | discardSession 120 | return () 121 | Nothing => do notLoggedIn 122 | return () 123 | 124 | 125 | 126 | handlePost (Just thread_id) (Just content) = do withSession (addPostToDB thread_id content) notLoggedIn 127 | pure () 128 | handlePost _ _ = do outputWithPreamble"

Error


There was an error processing your post." 129 | pure () 130 | 131 | newPostForm : Int -> UserForm 132 | newPostForm thread_id = do 133 | addHidden FormInt thread_id 134 | addTextBox "Post Content" FormString Nothing 135 | useEffects [CgiEffect, SessionEffect, SqliteEffect] 136 | addSubmit handlePost handlers 137 | 138 | 139 | showNewPostForm : Int -> CGIProg [SESSION (SessionRes SessionUninitialised), SQLITE ()] () 140 | showNewPostForm thread_id = do 141 | output htmlPreamble 142 | output "

Create new post

" 143 | addForm (newPostForm thread_id) 144 | output htmlPostamble 145 | 146 | ----------- 147 | -- Thread Creation 148 | ----------- 149 | 150 | threadInsert : Int -> String -> String -> Eff IO [SQLITE ()] (Maybe QueryError) 151 | threadInsert uid title content = do 152 | let query = "INSERT INTO `Threads` (`UserID`, `Title`) VALUES (?, ?)" 153 | insert_res <- executeInsert DB_NAME query [(1, DBInt uid), (2, DBText title)] 154 | case insert_res of 155 | Left err => return (Just err) 156 | Right thread_id => do 157 | post_res <- postInsert uid thread_id content 158 | if post_res then return Nothing else return $ Just (ExecError "post") 159 | 160 | 161 | addNewThread : String -> String -> SessionData -> EffM IO [CGI (InitialisedCGI TaskRunning), 162 | SESSION (SessionRes SessionInitialised), 163 | SQLITE ()] 164 | [CGI (InitialisedCGI TaskRunning), 165 | SESSION (SessionRes SessionUninitialised), 166 | SQLITE ()] () 167 | addNewThread title content sd = do 168 | case lookup USERID_VAR sd of 169 | Just (SInt uid) => 170 | do insert_res <- threadInsert uid title content 171 | case insert_res of 172 | Just err => do 173 | output $ "There was an error adding the thread to the database: " ++ show err 174 | discardSession 175 | return () 176 | Nothing => do 177 | output "Thread added successfully" 178 | discardSession 179 | return () 180 | Nothing => do notLoggedIn 181 | return () 182 | 183 | -- Create a new thread, given the title and content 184 | handleNewThread (Just title) (Just content) = do withSession (addNewThread title content) notLoggedIn 185 | pure () 186 | handleNewThread _ _ = do outputWithPreamble "

Error


There was an error posting your thread." 187 | pure () 188 | 189 | newThreadForm : UserForm 190 | newThreadForm = do 191 | addTextBox "Title" FormString Nothing 192 | addTextBox "Post Content" FormString Nothing -- password field would be good 193 | useEffects [CgiEffect, SessionEffect, SqliteEffect] 194 | addSubmit handleNewThread handlers 195 | 196 | 197 | showNewThreadForm : CGIProg [SESSION (SessionRes SessionUninitialised), SQLITE ()] () 198 | showNewThreadForm = do output htmlPreamble 199 | output "

New Thread

" 200 | addForm newThreadForm 201 | output htmlPostamble 202 | 203 | 204 | ----------- 205 | -- Registration 206 | ----------- 207 | 208 | insertUser : String -> String -> Eff IO [SQLITE ()] (Either QueryError Int) 209 | insertUser name pwd = executeInsert DB_NAME query bind_vals 210 | where query = "INSERT INTO `Users` (`Username`, `Password`) VALUES (?, ?)" 211 | bind_vals = [(1, DBText name), (2, DBText pwd)] 212 | 213 | 214 | userExists' : EffM IO [SQLITE (Either (SQLiteExecuting InvalidRow) (SQLiteExecuting ValidRow))] 215 | [SQLITE ()] Bool 216 | userExists' = 217 | if_valid then do 218 | finaliseValid 219 | closeDB 220 | return True 221 | else do 222 | finaliseInvalid 223 | closeDB 224 | return False 225 | 226 | 227 | userExists : String -> Eff IO [SQLITE ()] (Either QueryError Bool) 228 | userExists username = do 229 | conn_res <- openDB DB_NAME 230 | if_valid then do 231 | let sql = "SELECT * FROM `Users` WHERE `Username` = ?" 232 | ps_res <- prepareStatement sql 233 | if_valid then do 234 | bindText 1 username 235 | bind_res <- finishBind 236 | if_valid then do 237 | executeStatement 238 | res <- userExists' 239 | return $ Right res 240 | else do 241 | let be = getBindError bind_res 242 | cleanupBindFail 243 | return $ Left be 244 | else do 245 | cleanupPSFail 246 | return $ Left (getQueryError ps_res) 247 | else 248 | return $ Left (getQueryError conn_res) 249 | 250 | 251 | handleRegisterForm (Just name) (Just pwd) = do 252 | user_exists_res <- userExists name 253 | case user_exists_res of 254 | Left err => do outputWithPreamble "Error checking for user existence" 255 | pure () 256 | Right user_exists => 257 | if (not user_exists) then do 258 | insert_res <- insertUser name pwd 259 | case insert_res of 260 | Left err => do outputWithPreamble ("Error inserting new user" ++ (show err)) 261 | pure () 262 | Right insert_res => do outputWithPreamble "User created successfully!" 263 | pure () 264 | else do outputWithPreamble "This user already exists; please pick another name!" 265 | pure () 266 | 267 | handleRegisterForm _ _ = do outputWithPreamble "Error processing form input data." 268 | pure () 269 | 270 | registerForm : UserForm 271 | registerForm = do 272 | addTextBox "Username" FormString Nothing 273 | addTextBox "Password" FormString Nothing -- password field would be good 274 | useEffects [CgiEffect, SessionEffect, SqliteEffect] 275 | addSubmit handleRegisterForm handlers 276 | 277 | showRegisterForm : CGIProg [SESSION (SessionRes SessionUninitialised), SQLITE ()] () 278 | showRegisterForm = do output htmlPreamble 279 | output "

Create a new account

" 280 | addForm registerForm 281 | output htmlPostamble 282 | 283 | ----------- 284 | -- Login 285 | ----------- 286 | alreadyLoggedIn : SessionData -> 287 | EffM IO [CGI (InitialisedCGI TaskRunning), 288 | SESSION (SessionRes SessionInitialised), 289 | SQLITE ()] 290 | [CGI (InitialisedCGI TaskRunning), 291 | SESSION (SessionRes SessionUninitialised), 292 | SQLITE ()] () 293 | alreadyLoggedIn _ = do outputWithPreamble "

Error


You appear to already be logged in!" 294 | discardSession 295 | -- If the credentials match, return an ID 296 | -- Maybe consolidate the Maybe UserID into the Either, or possibly keep them 297 | -- distinct to encapsulate the system error vs auth failure 298 | authUser' : EffM IO [SQLITE (Either (SQLiteExecuting InvalidRow) 299 | (SQLiteExecuting ValidRow))] 300 | [SQLITE ()] 301 | (Either QueryError (Maybe UserID)) 302 | authUser' = 303 | if_valid then do 304 | user_id <- getColumnInt 0 305 | finaliseValid 306 | closeDB 307 | return $ Right (Just user_id) 308 | else do 309 | finaliseInvalid 310 | closeDB 311 | return $ Right Nothing 312 | 313 | authUser : String -> String -> Eff IO [SQLITE ()] (Either QueryError (Maybe UserID)) 314 | authUser username password = do 315 | conn_res <- openDB DB_NAME 316 | if_valid then do 317 | let sql = "SELECT `UserID` FROM `Users` WHERE `Username` = ? AND `Password` = ?" 318 | ps_res <- prepareStatement sql 319 | if_valid then do 320 | bindText 1 username 321 | bindText 2 password 322 | bind_res <- finishBind 323 | if_valid then do 324 | executeStatement 325 | authUser' 326 | else do 327 | let be = getBindError bind_res 328 | cleanupBindFail 329 | return $ Left be 330 | else do 331 | cleanupPSFail 332 | return $ Left (getQueryError ps_res) 333 | else 334 | return $ Left (getQueryError conn_res) 335 | 336 | 337 | setSession : UserID -> Eff IO [CGI (InitialisedCGI TaskRunning), SESSION (SessionRes SessionUninitialised), SQLITE ()] Bool 338 | setSession user_id = do 339 | create_res <- createSession [(USERID_VAR, SInt user_id)] 340 | sess_res <- setSessionCookie 341 | db_res <- writeSessionToDB 342 | return (sess_res && db_res) 343 | 344 | 345 | handleLoginForm (Just name) (Just pwd) = do 346 | auth_res <- authUser name pwd 347 | case auth_res of 348 | Right (Just uid) => do 349 | set_sess_res <- setSession uid 350 | if set_sess_res then do 351 | output $ "Welcome, " ++ name 352 | return () 353 | else do 354 | output "Could not set session" 355 | return () 356 | Right Nothing => do 357 | output "Invalid username or password" 358 | return () 359 | Left err => do 360 | output $ "Error: " ++ (show err) 361 | return () 362 | 363 | 364 | loginForm : UserForm 365 | loginForm = do 366 | addTextBox "Username" FormString Nothing 367 | addTextBox "Password" FormString Nothing -- password field would be good 368 | useEffects [CgiEffect, SessionEffect, SqliteEffect] 369 | addSubmit handleLoginForm handlers 370 | 371 | showLoginForm : CGIProg [SESSION (SessionRes SessionUninitialised), SQLITE ()] () 372 | showLoginForm = do output htmlPreamble 373 | output "

Log in

" 374 | addForm loginForm 375 | output "" 376 | 377 | 378 | 379 | ----------- 380 | -- Post / Thread Display 381 | ----------- 382 | 383 | collectPostResults : Eff IO [SQLITE (SQLiteExecuting ValidRow)] (List DBVal) -- (List (String, String)) 384 | collectPostResults = do name <- getColumnText 0 385 | content <- getColumnText 1 386 | pure [DBText name, DBText content] 387 | -- Gets the posts 388 | getPosts : Int -> Eff IO [SQLITE ()] (Either QueryError ResultSet) 389 | getPosts thread_id = 390 | executeSelect DB_NAME query bind_vals collectPostResults 391 | where query = "SELECT `Username`, `Content` FROM `Posts` NATURAL JOIN `Users` WHERE `ThreadID` = ?" 392 | bind_vals = [(1, DBInt thread_id)] 393 | 394 | 395 | collectThreadResults : Eff IO [SQLITE (SQLiteExecuting ValidRow)] (List DBVal) 396 | collectThreadResults = do thread_id <- getColumnInt 0 397 | title <- getColumnText 1 398 | uid <- getColumnInt 2 399 | username <- getColumnText 3 400 | pure [DBInt thread_id, DBText title, DBInt uid, DBText username] 401 | 402 | -- Returns (Title, Thread starter ID, Thread starter name) 403 | getThreads : Eff IO [SQLITE ()] (Either QueryError ResultSet) 404 | getThreads = executeSelect DB_NAME query [] collectThreadResults 405 | where query = "SELECT `ThreadID`, `Title`, `UserID`, `Username` FROM `Threads` NATURAL JOIN `Users`" 406 | 407 | 408 | traversePosts : ResultSet -> Eff IO [CGI (InitialisedCGI TaskRunning)] () 409 | traversePosts [] = pure () 410 | traversePosts (x :: xs) = do traverseRow x 411 | traversePosts xs 412 | where traverseRow : List DBVal -> Eff IO [CGI (InitialisedCGI TaskRunning)] () 413 | traverseRow ((DBText name)::(DBText content)::[]) = output $ "" ++ name ++ "" ++ content ++ "" 414 | traverseRow _ = pure () -- invalid row, discard 415 | 416 | printPosts : ThreadID -> CGIProg [SQLITE ()] () 417 | printPosts thread_id = do 418 | post_res <- getPosts thread_id 419 | case post_res of 420 | Left err => do output $ "Could not retrieve posts, error: " ++ (show err) 421 | return () 422 | Right posts => do output "" 423 | traversePosts posts 424 | output "
" 425 | output $ "New post
" 426 | return () 427 | 428 | traverseThreads : ResultSet -> Eff IO [CGI (InitialisedCGI TaskRunning)] () 429 | traverseThreads [] = pure () 430 | traverseThreads (x::xs) = do traverseRow x 431 | traverseThreads xs 432 | where traverseRow : List DBVal -> Eff IO [CGI (InitialisedCGI TaskRunning)] () 433 | traverseRow ((DBInt thread_id)::(DBText title)::(DBInt user_id)::(DBText username)::[]) = 434 | (output $ "" ++ title ++ "" ++ username ++ "") 436 | traverseRow _ = pure () 437 | 438 | printThreads : CGIProg [SQLITE ()] () 439 | printThreads = do 440 | thread_res <- getThreads 441 | case thread_res of 442 | Left err => do output $ "Could not retrieve threads, error: " ++ (show err) 443 | return () 444 | Right threads => do output htmlPreamble 445 | output "" 446 | traverseThreads threads 447 | output "
TitleAuthor

" 448 | output "Create a new thread
" 449 | output "Register
" 450 | output "Log In
" 451 | output htmlPostamble 452 | return () 453 | ----------- 454 | -- Request handling 455 | ----------- 456 | handleNonFormRequest : Maybe String -> Maybe Int -> CGIProg [SESSION (SessionRes SessionUninitialised), SQLITE ()] () 457 | handleNonFormRequest (Just "newthread") Nothing = showNewThreadForm 458 | handleNonFormRequest (Just "newpost") (Just thread_id) = showNewPostForm thread_id 459 | handleNonFormRequest (Just "showthread") (Just thread_id) = printPosts thread_id 460 | handleNonFormRequest (Just "register") Nothing = showRegisterForm 461 | handleNonFormRequest (Just "login") Nothing = showLoginForm 462 | handleNonFormRequest Nothing _ = printThreads 463 | 464 | 465 | 466 | -- Hacky, probably best to use the parser 467 | strToInt : String -> Int 468 | strToInt s = cast s 469 | 470 | handleRequest : CGIProg [SESSION (SessionRes SessionUninitialised), SQLITE ()] () 471 | handleRequest = do handler_set <- isHandlerSet 472 | if handler_set then do 473 | handleForm handlers 474 | return () 475 | else do 476 | action <- queryGetVar "action" 477 | thread_id <- queryGetVar "thread_id" 478 | handleNonFormRequest action (map strToInt thread_id) 479 | 480 | main : IO () 481 | main = do runCGI [initCGIState, InvalidSession, ()] handleRequest 482 | pure () 483 | 484 | -------------------------------------------------------------------------------- /examples/MessageBoard/Makefile: -------------------------------------------------------------------------------- 1 | all : 2 | idris -p effects -p idrisweb -p simpleparser -o MessageBoard Main.idr 3 | -------------------------------------------------------------------------------- /examples/MessageBoard/db.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE Users ( 2 | UserID INTEGER NOT NULL PRIMARY KEY, 3 | Username TEXT NOT NULL, 4 | Password TEXT NOT NULL 5 | ); 6 | 7 | CREATE TABLE Threads ( 8 | ThreadID INTEGER NOT NULL PRIMARY KEY, 9 | Title TEXT NOT NULL, 10 | UserID INTEGER NOT NULL references `Users` (`UserID`) 11 | ); 12 | 13 | CREATE TABLE Posts ( 14 | PostID INTEGER NOT NULL PRIMARY KEY, 15 | ThreadID INTEGER NOT NULL references `Threads` (`ThreadID`), 16 | Content TEXT NOT NULL, 17 | UserID INTEGER NOT NULL references `Users` (`UserID`) 18 | ); 19 | 20 | -------------------------------------------------------------------------------- /idris_web.ipkg: -------------------------------------------------------------------------------- 1 | package idrisweb 2 | 3 | opts = "-p effects -p simpleparser --typecase" 4 | sourcedir = src 5 | modules = IdrisWeb.Common.Random.RandC, IdrisWeb.DB.SQLite.SQLiteNew, IdrisWeb.DB.SQLite.SQLiteCodes, IdrisWeb.CGI.CgiTypes, IdrisWeb.CGI.Cgi, IdrisWeb.CGI.CgiUtils, IdrisWeb.Session.Session, IdrisWeb.Session.SessionUtils 6 | 7 | makefile = MakefileC 8 | objs = rand_c.o, rand_c.h, sqlite3api.o, sqlite3api.h 9 | 10 | -------------------------------------------------------------------------------- /paper/conclusion.tex: -------------------------------------------------------------------------------- 1 | \section{Related Work} 2 | \citet{meijer:cgi} implemented a CGI library which was among the first 3 | libraries to handle web scripting monadically, and allows the user to implement 4 | application logic without having to consider the low-level details such as 5 | parsing in CGI data from the environment, or printing headers to the remote 6 | browser. The library also provides support for cookies and basic form handling. 7 | 8 | \citet{thiemann:wash} adds the notion of a CGI Session for maintaining 9 | state, and provides more sophisticated form-handling methods. In particular, 10 | callbacks may be associated with submit buttons, with nameless representations 11 | for form inputs. Both implementations of the CGI library, 12 | being built upon monads, mean that the use of additional effects such as 13 | database access is achieved either through monad transformers or 14 | performing arbitrary IO operations. Both of these approaches are limited---the 15 | former does not scale well to multiple effects, and the latter allows for the 16 | introduction of errors by allowing the violation of resource usage protocols. 17 | 18 | \citet{plasmeijer:idata} describe an alternative approach to type-safe form 19 | handling through the 20 | \textit{i}nteractive \textit{Data}, or \idata{} abstraction. Instead of 21 | processing being triggered by form submission, as in the approach described in 22 | this paper, applications created in the \idata{} toolkit are 23 | edit-driven. This means that upon a component being edited, a computation 24 | occurs, given the state of the current form. Should a user enter invalid data, for example by entering 25 | text in a field designated for integers, the change will be reverted. This is 26 | demonstrated practically through the use of \idata{} to implement a conference 27 | management system \cite{plasmeijer:cms}. 28 | 29 | The concept of \idata{} is taken further by the introduction of \itasks{} 30 | \cite{plasmeijer:itasks}, which make use of a workflow system to allow multiple 31 | \idata{} forms to interact with one another. This is achieved using 32 | high-level combinators which allow the implementation of concepts such as 33 | recursion, sequence and choice in a scalable fashion. 34 | 35 | Ur\/Web \cite{urweb} is a library built for the Ur language, which does not use 36 | full dependent types but does have an expressive type system with 37 | record types and type-level computation. By using these concepts, 38 | Ur\/Web may generate provably correct and unexploitable DOM code and SQL 39 | queries from records, without requiring developers to supply proofs. In 40 | contrast to using runtime code generation, which is prone to obscure code 41 | generation errors, Ur\/Web makes use of its static type system to guarantee 42 | that metaprograms---in this case, generated SQL and DOM code---must be correct 43 | and secure. Such ideas regarding the use of static checking of metaprogram 44 | generation will be extremely useful when considering an object-relational 45 | mapping system, which we hope to implement in the near future. It will also be 46 | interesting to see how such concepts may be applied with a yet more expressive 47 | type system involving full dependent types. 48 | 49 | Formlets \cite{cooper:formlets} are a well-known functional abstraction over web forms, making use of McBride and Paterson's applicative functors \cite{mcbride:applicative} to provide an extensible and powerful method of building and handling web forms. 50 | Our approach differs in that we check that handler functions conform to the types of the elements in the forms by parameterising the resource associated with the form construction effect, as opposed to using a preprocessor to rewrite the form elements in applicative notation. 51 | Our framework does not yet support composition of sections of forms, as is the case with formlets, but we foresee no problems with extending our DSL to add this functionality. 52 | 53 | Ensuring conformance to resource usage protocols has been attempted using the 54 | notion of \emph{typestate} in object-oriented languages 55 | \cite{deline:typestates}. Our approach differs in that we make no changes to 56 | the type system in order to implement this functionality; we check resource 57 | usage protocol conformance directly within \idris{}. Additionally, our 58 | handler-based approach gives greater control over side effects. 59 | 60 | Java is often used as a language to write enterprise-level web applications. Frameworks such as the Java Persistence API (JPA) \cite{jpa} use Java annotations to translate data models into the appropriate database schemata, but such code may soon become unwieldy due to the large amount of redundant boilerplate code such as accessor and mutator functions. WebDSL \cite{webdsl} is a domain-specific language written primarily to 61 | introduce new abstractions which aim to reduce the amount of boilerplate code 62 | that must be written and maintained by developers. 63 | The DSL is parsed into an abstract syntax tree, modified using rewrite rules, and elaborated back into Java code. 64 | %WebDSL also applies similar concepts to implement a \textit{template system} for the presentation of data entities. We look to 65 | %implement many of these ideas, but as effects within the IdrisWeb 66 | %framework, as with the form construction effect. 67 | 68 | %----------------------------- 69 | %----------------------------- 70 | 71 | \section{Conclusions} 72 | 73 | Dependently-typed languages promise to support machine checkable program 74 | correctness proofs, but to date they have remained relatively unused for 75 | practical purposes. By using embedded domain-specific languages, we can 76 | abstract away some of the complexities of creating correctness proofs and 77 | provide expressive libraries, giving guarantees by the successful compilation 78 | of a program (assuming the use of specific enough types) without additional 79 | proofs. 80 | 81 | Our framework provides several static 82 | guarantees. Data submitted by users is inherently unsafe and 83 | means systems are vulnerable to attacks 84 | such as SQL injection. This particular threat is ameliorated due 85 | to elements being associated with specific types during form construction. This 86 | immediately eliminates the possibilities of SQL injection attacks on non-string 87 | types. Since failures are handled transparently, no runtime errors are written 88 | to the browser, meaning that attackers may not use such information to aid 89 | attacks. Additionally, since checking is performed on the types of the form 90 | elements and the types of arguments accepted by the handler, it is impossible 91 | to associate a form with a handler incompatible with the submitted data. 92 | 93 | Many external libraries also follow (unchecked or dynamically checked) 94 | resource usage protocols. 95 | Incorrect usage is however still possible, for 96 | example by forgetting to release acquired resources or failing to 97 | initialise a library correctly. By creating high-level bindings to these 98 | libraries, however, we may statically enforce these resource-usage protocols, 99 | ensuring that the libraries are used correctly. Whilst previous work has 100 | demonstrated that this is possible through the use of embedded DSLs 101 | \cite{brady:edsl} and dependent algebraic effects \cite{brady:effects}, 102 | this paper has provided more substantial examples of real-world applications. 103 | 104 | In particular, the framework guarantees that it is not possible for a CGI 105 | application to 106 | produce an internal server error due to content being written to the remote 107 | host prior to headers. With regard to database access, we may statically 108 | guarantee that library calls are made in the correct order, and calls to 109 | retrieve rows of data are made only when more data is available. Additionally, by encoding desired invariants within operation types, we may gain static guarantees about adherence to resource usage protocols and failure handling. 110 | Enforcing resource usage protocols also guards against common programmer 111 | errors, saving debugging time by identifying errors at compile time. 112 | 113 | \subsection{Further Work} 114 | 115 | We have shown that embedded domain-specific languages using dependent types and 116 | algebraic effects can be used to increase confidence in web applications, but much more 117 | can be done using the same approach. 118 | 119 | There are many other applications which make use of specific resource usage 120 | protocols, for example popular cryptography libraries such as 121 | \textit{Sodium}\footnote{\texttt{https://github.com/jedisct1/libsodium}}. 122 | Applying a similar approach would allow for sensitive programs requiring 123 | cryptographic routines to be written using a language with full dependent 124 | types, in turn adding an extra layer of confidence in their security. 125 | 126 | Whilst the use of CGI allows for experimenting with the use of dependent types 127 | in a real-world scenario such as web programming, there remain practical 128 | considerations about its scalability, as a separate process must be created for 129 | each individual request. We believe that the use of FastCGI may alleviate this, 130 | but ultimately, we would like to create a web server written in \idris{}, which 131 | would make more efficient usage of resources. 132 | 133 | Since at this stage we have concentrated on the use of dependent types for 134 | enforcing resource usage protocols and type-safe form handling, we currently 135 | handle the generation of HTML in an unstructured manner. Future work will 136 | entail a DOM library to facilitate the generation and manipulation of HTML, in 137 | turn giving stronger guarantees about its correctness. Other planned features 138 | include a template system, allowing for web pages to be automatically generated 139 | from data, and an object-relational mapping system. 140 | It would also be interesting to 141 | explore the use of continuation-passing approaches \cite{queinnec:ioc} to enhance the usability of the framework. 142 | 143 | Type providers, as originally implemented in F\# \cite{msr:tp}, allow external data sources to be used to import 144 | external information to be used during compilation. 145 | In this way, it becomes possible to use the extra type 146 | information to statically ensure the validity of artefacts such as SQL 147 | queries and data structures. If data structures within the program do not 148 | conform to a given database schema, for example, then the program will not 149 | type-check. Type providers have been implemented for 150 | \idris{} 151 | \cite{christiansen:dtp}, exploiting the fact that types can be 152 | calculated by functions to avoid unsafely generating extra code in the type provider 153 | step. We believe that this technique would be an interesting avenue of exploration to provide further static guarantees about the form of database queries. 154 | 155 | Dependently-typed languages provide great promise for the construction of 156 | secure and correct programs. Through the use of embedded domain-specific 157 | languages, we hope that more developers may benefit from the extra guarantees 158 | afforded by dependent types, resulting in more stable, secure applications. 159 | 160 | % Cryptography bindings would be really good. 161 | % Integration with a web server instead of doing everything over CGI 162 | % Improvements to form handling system 163 | % Less raw SQL, use get more type-safety by using more complex EDSLs for database access thus further minimising errors 164 | -------------------------------------------------------------------------------- /paper/effects.tex: -------------------------------------------------------------------------------- 1 | \section{An overview of the \texttt{Effects} framework} 2 | \label{effects} 3 | 4 | \texttt{Effects}~\cite{brady:effects} is an \idris{} library which handles 5 | side-effects such as state, exceptions, and I/O as \emph{algebraic 6 | effects}~\cite{Plotkin2009}. In particular, it supports parameterising effects 7 | by an input and output \emph{state}, which permits effectful programs to track 8 | the progress of a resource usage protocol. Effectful programs are written 9 | in a monadic style, with \texttt{do}-notation, with their type stating which 10 | specific effects are available: 11 | %Effectful 12 | %programs are described using the following data type, 13 | %in the simplest case: 14 | 15 | \begin{SaveVerbatim}{efftype} 16 | 17 | Eff : (m : Type -> Type) -> 18 | (es : List EFFECT) -> (a : Type) -> Type 19 | 20 | \end{SaveVerbatim} 21 | \useverb{efftype} 22 | 23 | \noindent 24 | \texttt{Eff} is parameterised over a \emph{computation context}, \texttt{m}, 25 | which describes the context in which the effectful program will be run, a 26 | list of side effects \texttt{es} that the program is permitted to use, and the 27 | program'’s return type \texttt{a}. The name \texttt{m} for the computation context is 28 | suggestive of a monad, but there is no requirement for it to be so. 29 | 30 | For example, the following type carries an integer state, 31 | throws an exception of type \texttt{String} if the state reaches 100, 32 | and runs in a \texttt{Maybe} context: 33 | 34 | \begin{SaveVerbatim}{addState} 35 | 36 | addState : Eff Maybe [STATE Int, EXCEPTION String] () 37 | addState = do val <- get 38 | when (val == 100) (raise "State too big") 39 | put (val + 1) 40 | 41 | \end{SaveVerbatim} 42 | \useverb{addState} 43 | 44 | \subsection{Implementing Effects} 45 | 46 | Effects such as `State' and `Exception' are described as algebraic data types, 47 | and run by giving \emph{handlers} for specific computation contexts. 48 | Effects have a corresponding \emph{resource} (in the case of state, the 49 | resource is simply the current state). Executing an effectful operation may 50 | change the resource and return a value: 51 | 52 | \begin{SaveVerbatim}{efffam} 53 | 54 | Effect : Type 55 | Effect = (in_res : Type) -> (out_res : Type) -> 56 | (val : Type) -> Type 57 | 58 | \end{SaveVerbatim} 59 | \useverb{efffam} 60 | 61 | \noindent 62 | For example, the state effect is described as follows: 63 | 64 | \begin{SaveVerbatim}{stateeff} 65 | 66 | data State : Effect where 67 | Get : State a a a 68 | Put : b -> State a b () 69 | 70 | \end{SaveVerbatim} 71 | \useverb{stateeff} 72 | 73 | \noindent 74 | That is, \texttt{Get} returns a value of type \texttt{a} without updating 75 | the resource type. \texttt{Put} returns nothing, but has the effect of updating 76 | the resource. To make an effect usable, we implement a handler 77 | for a computation context by making an instance of the following class: 78 | 79 | \begin{SaveVerbatim}{effhandler} 80 | 81 | class Handler (e : Effect) (m : Type -> Type) where 82 | handle : res -> (eff : e res res' t) -> 83 | (k: res' -> t -> m a) -> m a 84 | 85 | \end{SaveVerbatim} 86 | \useverb{effhandler} 87 | 88 | \noindent 89 | The \texttt{handle} function takes the input resource, an effect which may 90 | update that resource and execute a side-effect, and a continuation \texttt{k} 91 | which takes the updated resource and the return value of the effect. We use 92 | a continuation here primarily because there is no restriction on the number of 93 | times a handler may invoke the continuation (raising an exception, for example, 94 | will not invoke it). Reading and updating states is handled 95 | for all computation contexts \texttt{m}: 96 | 97 | \begin{SaveVerbatim}{statehandler} 98 | 99 | instance Handler State m where 100 | handle st Get k = k st st 101 | handle st (Put n) k = k n () 102 | 103 | \end{SaveVerbatim} 104 | \useverb{statehandler} 105 | 106 | \noindent 107 | Finally, we promote \texttt{State} into a concrete effect \texttt{STATE}, and 108 | the \texttt{Get} and \texttt{Put} operations into functions in \texttt{Eff}, as 109 | follows: 110 | 111 | \begin{SaveVerbatim}{stateconc} 112 | 113 | STATE : Type -> EFFECT 114 | STATE t = MkEff t State 115 | 116 | get : Eff m [STATE x] x 117 | get = Get 118 | 119 | put : x -> Eff m [STATE x] () 120 | put val = Put val 121 | 122 | \end{SaveVerbatim} 123 | \useverb{stateconc} 124 | 125 | \noindent 126 | A concrete effect is simply an algebraic effect type paired with its current 127 | resource type. This, and other 128 | technical details, are explained in full elsewhere~\cite{brady:effects}. 129 | For the purposes of this paper, it suffices to know how to describe and 130 | handle new algebraic effects. 131 | 132 | \subsection{Resource Protocols as Effects} 133 | \label{rp-effects} 134 | \begin{SaveVerbatim}{fileeff} 135 | {- { Input resource type } { Output resource type } { Value } -} 136 | 137 | data FileIO : Effect where 138 | Open : String -> (m : Mode) -> FileIO () (Either () (OpenFile m)) () 139 | Close : FileIO (OpenFile m) () () 140 | 141 | ReadLine : FileIO (OpenFile Read) (OpenFile Read) String 142 | WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) () 143 | EOF : FileIO (OpenFile Read) (OpenFile Read) Bool 144 | \end{SaveVerbatim} 145 | 146 | \begin{figure*}[t] 147 | \begin{center} 148 | \useverb{fileeff} 149 | \end{center} 150 | \caption{File Protocol Effect} 151 | \label{fig:fileeffect} 152 | \end{figure*} 153 | More generally, a program might modify the set of effects available. 154 | This might be desirable for several reasons, such as adding a new 155 | effect, or to update an index of a dependently typed state. In this 156 | case, we describe programs using the \texttt{EffM} data type: 157 | 158 | \begin{SaveVerbatim}{effmtype} 159 | 160 | EffM : (m : Type -> Type) -> 161 | (es : List EFFECT) -> (es' : List EFFECT) -> 162 | (a : Type) -> Type 163 | 164 | \end{SaveVerbatim} 165 | \useverb{effmtype} 166 | 167 | \noindent 168 | \texttt{EffM} is parameterised over the context and type as before, but 169 | separates input effects (\texttt{es}) from output effects (\texttt{es'}). 170 | In fact, \texttt{Eff} 171 | is defined in terms of \texttt{EffM}, with equal input/output effects. 172 | We can use this to describe how effects follow resource protocols. A simple 173 | example is a file access protocol, where a file must be opened before it 174 | is read or written, and a file must be closed on exit. 175 | 176 | Figure \ref{fig:fileeffect} shows how the protocol is encoded as an 177 | effect. 178 | Note that the types of the input and output resources describes how resource 179 | state changes in each operation: opening a file may fail, so 180 | changes an empty resource to 181 | a resource containing either a unit or an open file; 182 | reading a line is only possible if the 183 | resource is a file open for reading, etc. 184 | The handler for this effect for an \texttt{IO} computation context will 185 | execute the required primitive I/O actions. 186 | 187 | The following program type checks, and therefore implicitly carries 188 | a proof that the file resource protocol is followed correctly: 189 | 190 | \begin{SaveVerbatim}{testfile} 191 | 192 | testFile : Eff IO [FILE_IO (), STDIO] () 193 | testFile = do open "testFile" Read 194 | if_valid then do str <- readLine 195 | close 196 | putStrLn str 197 | else putStrLn "Error" 198 | 199 | \end{SaveVerbatim} 200 | \useverb{testfile} 201 | 202 | \noindent 203 | The type of \texttt{testFile} states 204 | that File I/O and console I/O are available effects, and in particular that 205 | the resource associated with the File I/O will be in the same state on entry 206 | and exit. We use \texttt{if\_valid} to handle possible failure---this is 207 | a function provided by the \texttt{Effects} library which checks whether 208 | a resource of type \texttt{Either a b} indicates failure (\texttt{Left a}) 209 | or success (\texttt{Right b}). In this case, the initial resource in the valid 210 | branch is \texttt{OpenFile Read}, indicating that the file has been successfully 211 | opened for reading, whereas in the failing branch, the resource remains as \texttt{()}. 212 | 213 | Attempting to write to the file, failing to check for 214 | success, or failing to open or close the 215 | file, would cause a \emph{compile-time} error. 216 | 217 | We will use this technique extensively 218 | throughout this paper: describe a resource usage protocol in terms of 219 | state transitions; implement an effect which captures that protocol; and implement 220 | programs which, by using this effect, implicitly carry a proof that the resource 221 | protocol has been correctly followed. 222 | 223 | 224 | % ================================================= 225 | % ================================================= -------------------------------------------------------------------------------- /paper/forms.tex: -------------------------------------------------------------------------------- 1 | \section{Dependently-Typed Form Handling} 2 | 3 | \label{form} 4 | Programming web applications often involves processing user data, which may 5 | then be used in further effectful computations. Data submitted using a form is 6 | transmitted as a string as part of an HTTP request, which 7 | traditionally involves losing associated type information. 8 | 9 | This can in turn lead to risks; developers may assume that data is 10 | of a certain type, and therefore discount the possibility that it may have been 11 | modified by an attacker. One example would be the traversal of paginated data, 12 | in which a form is used to make a request to retrieve the next page of data. 13 | This may involve sending an integer detailing the current page, which could be 14 | used in a query such as: 15 | 16 | \begin{SaveVerbatim}{selectq} 17 | 18 | 'SELECT `name`, `address` FROM `staff` LIMIT ' + 19 | page + ', 5'; 20 | 21 | \end{SaveVerbatim} 22 | \useverb{selectq} 23 | 24 | \noindent 25 | The \texttt{page} variable is assumed to be an integer, but may instead be 26 | modified by an attacker to include a malicious string which would alter the 27 | semantics of the query, allowing an attacker to execute a blind SQL injection 28 | attack. % Might be a good idea to cite an SQL injection paper which uses LIMIT 29 | % clauses here 30 | 31 | In this section, we present a DSL 32 | for the creation of web forms which preserve type information, implemented 33 | as a resource-dependent algebraic effect. Once the form has 34 | been submitted, retrieved information is passed directly to a 35 | developer-specified function for handling, without the need to manually check 36 | and deserialise data. 37 | 38 | We begin with a simple example of a form which requests a user's name, and 39 | echoes it back. Firstly, we define a form handler which echoes back a string 40 | provided by the form handler. It has one argument of type \texttt{Maybe 41 | String}, which accounts for the possibility that the user may have 42 | provided invalid data: 43 | 44 | \begin{SaveVerbatim}{sayhello} 45 | 46 | echo : Maybe String -> 47 | FormHandler [CGI (InitialisedCGI TaskRunning)] 48 | echo (Just name) = output ("Hello, " ++ name ++ "!") 49 | echo _ = output "Error!" 50 | 51 | \end{SaveVerbatim} 52 | \useverb{sayhello} 53 | 54 | \noindent 55 | We then specify this in a list of handlers, detailing the arguments, available effects, handler function and unique identifier: 56 | 57 | \begin{SaveVerbatim}{handerlist} 58 | 59 | handlers : HandlerList 60 | handlers = [handler args=[FormString], 61 | effects=[CgiEffect], 62 | fn=echo, 63 | name="echo"] 64 | 65 | \end{SaveVerbatim} 66 | \useverb{handerlist} 67 | 68 | \noindent 69 | We also define a form to take in a name from the user, and specify that it 70 | should use the \texttt{echo} handler. 71 | 72 | \begin{SaveVerbatim}{showhello} 73 | 74 | showHelloForm : UserForm 75 | showHelloForm = do 76 | addTextBox "Name" FormString Nothing 77 | useEffects [CgiEffect] 78 | addSubmit echo handlers 79 | 80 | \end{SaveVerbatim} 81 | \useverb{showhello} 82 | 83 | \noindent 84 | Finally, we specify that if data has been submitted for processing, then it 85 | should be passed to the form handler. If not, then the form should be shown. 86 | 87 | \begin{SaveVerbatim}{cgihello} 88 | 89 | cgiHello : CGIProg [] () 90 | cgiHello = do 91 | handler_set <- isHandlerSet 92 | if handler_set then do 93 | handleForm handlers 94 | return () 95 | else do 96 | addForm showHelloForm 97 | return () 98 | 99 | main : IO () 100 | main = runCGI [initCGIState] cgiHello 101 | 102 | \end{SaveVerbatim} 103 | \useverb{cgihello} 104 | 105 | \noindent 106 | When this CGI application is invoked, it will begin by outputting a form to the 107 | page, requesting a name from the user. Upon submission of the form, the form 108 | handler will be invoked, and the name will be used in the output. 109 | 110 | In Sections~\ref{formcons} and~\ref{formhandling}, we examine implementation 111 | of the form-handling system: the effect which allows the creation of 112 | forms, and the handling code which deserialises the data and passes it to the 113 | user-specified handler function. 114 | 115 | \subsection{Form Construction} 116 | \label{formcons} 117 | Each form element holds a value of a specific type, which, assuming that the 118 | correct type of data is given by the user, is passed directly to the 119 | handler function. In order to encapsulate this, we firstly define the allowed 120 | data types as part of an algebraic data type, \texttt{FormTy}. 121 | 122 | \begin{SaveVerbatim}{formty} 123 | 124 | data FormTy = FormString | FormInt 125 | | FormBool | FormFloat 126 | | FormList FormTy 127 | 128 | \end{SaveVerbatim} 129 | \useverb{formty} 130 | 131 | \noindent 132 | %Since types in \idris{} are first-class, 133 | We convert 134 | from an abstract to a concrete representation of an allowed form type as 135 | follows: 136 | 137 | \begin{SaveVerbatim}{interpformty} 138 | 139 | interpFormTy : FormTy -> Type 140 | interpFormTy FormString = String 141 | interpFormTy FormInt = Int 142 | interpFormTy FormBool = Bool 143 | interpFormTy FormFloat = Float 144 | interpFormTy (FormList a) = List (interpFormTy a) 145 | 146 | \end{SaveVerbatim} 147 | \useverb{interpformty} 148 | 149 | \begin{SaveVerbatim}{formeff} 150 | using (G : List FormTy, E : List WebEffect) 151 | data FormRes : List FormTy -> List WebEffect -> Type where 152 | FR : Nat -> List FormTy -> List WebEffect -> String -> FormRes G E 153 | 154 | data Form : Effect where 155 | AddTextBox : (label : String) -> (fty : FormTy) -> (Maybe (interpFormTy fty)) -> 156 | Form (FormRes G E) (FormRes (fty :: G) E) () 157 | AddSelectionBox : (label : String) -> (fty : FormTy) -> (vals : Vect m (interpFormTy fty)) -> 158 | (names : Vect m String) -> 159 | Form (FormRes G E) (FormRes (fty :: G) E) () 160 | AddRadioGroup : (label : String) -> (fty : FormTy) -> (vals : Vect m (interpFormTy fty)) -> 161 | (names : Vect m String) -> (default : Int) -> 162 | Form (FormRes G E) (FormRes (fty :: G) E) () 163 | AddCheckBoxes : (label : String) -> (fty : FormTy) -> (vals : Vect m (interpFormTy fty)) -> 164 | (names : Vect m String) -> (checked_boxes : Vect m Bool) -> 165 | Form (FormRes G E) (FormRes ((FormList fty) :: G) E) () 166 | Submit : (mkHandlerFn ((reverse G), E)) -> String -> 167 | Form (FormRes G E) (FormRes [] []) String 168 | \end{SaveVerbatim} 169 | 170 | \begin{figure*}[t] 171 | \begin{center} 172 | \useverb{formeff} 173 | \end{center} 174 | \caption{Form Effect} 175 | \label{fig:formeffect} 176 | \end{figure*} 177 | 178 | \noindent 179 | Again, we use \texttt{Effects} to build a form. 180 | By recording 181 | the type of each form element as it is added in the type of the form, we may 182 | statically ensure that the user-supplied handler function is of the correct 183 | type to handle the data supplied by the form: using an 184 | incompatible handler will result in a compile-time type error. The \texttt{Form} 185 | effect and associated resource \texttt{FormRes} is given in Figure 186 | \ref{fig:formeffect}. 187 | 188 | The \texttt{using} notation indicates that where \texttt{G} and \texttt{E} occur within the block, they correspond to \emph{implicit arguments} within the type of the form construction resource. 189 | \texttt{G} is of type \texttt{List FormTy}, indicating the types of the elements within the form, and \texttt{E} is of type \texttt{List WebEffect}. This allows us to record the types of form elements, which we may later use to ensure that the type of the handler function corresponds to the types of the elements within the form. 190 | %The \texttt{using} notation here indicates that within 191 | %the block, where \texttt{G} and \texttt{E} occur they are implicit arguments with 192 | %the given resource type. 193 | 194 | The general process of form construction is illustrated by the \texttt{AddTextBox} 195 | and \texttt{Submit} operations of the \texttt{Form} effect, shown in Figure~\ref{fig:formeffect}. These use the resource associated with the effect, \texttt{FormRes}, to construct the form. Adding a field such as a text box adds a new type, 196 | \texttt{fty} to the list of field types, carried in the resource. When the form 197 | is complete, the \texttt{Submit} operation adds a submit button and returns the 198 | HTML text for the form, flushing the list of field types, and using it to 199 | construct the type for an appropriate handler function. 200 | % 201 | To specify a form instance, we define a function of type \texttt{UserForm}: 202 | 203 | \begin{SaveVerbatim}{userform} 204 | 205 | UserForm : Type 206 | UserForm = EffM m [FORM (FormRes []) 207 | (FormRes [])] String 208 | \end{SaveVerbatim} 209 | \useverb{userform} 210 | 211 | \noindent 212 | %All forms are required to include a submit button, as mandated by the 213 | %requirement that 214 | % 215 | The input and output resource contains an empty list of types, which means that 216 | any form which includes fields must also include a submit button. Adding fields 217 | adds to the list of types, and only adding a submit button empties that list. 218 | Note that there is no need to restrict this effect to running in the \texttt{IO} 219 | monad since creating a form merely returns HTML text, with no side-effects by 220 | default. 221 | 222 | Before associating a handler function with the form, we must specify the 223 | effects available to the handler. This is done with 224 | \texttt{useEffects}, which updates the list of effects in the type of the form 225 | resource. By doing this, we may subsequently use the effects in calculations at 226 | the type level, in particular when calculating the type of the handler function 227 | for the form. 228 | 229 | \begin{SaveVerbatim}{useeffs} 230 | 231 | useEffects : (effs : List WebEffect) -> 232 | EffM m [FORM (FormRes G E)] 233 | [FORM (FormRes G effs)] () 234 | useEffects effs = UseEffects effs 235 | 236 | \end{SaveVerbatim} 237 | \useverb{useeffs} 238 | 239 | \noindent 240 | A \texttt{WebEffect} is an effect which is usable in a web application, and can 241 | be converted to an \texttt{EFFECT} using: 242 | 243 | \begin{SaveVerbatim}{interpwebeff} 244 | webEffect : WebEffect -> EFFECT 245 | \end{SaveVerbatim} 246 | \useverb{interpwebeff} 247 | 248 | While it is not possible to serialise arbitrary effects due to the associated 249 | difficulties with serialising initial resource environments, we allow for three 250 | effects to be serialised: \texttt{CGI}, \texttt{SQLITE} and \texttt{SESSION}. 251 | This is, however, not an inherent limitation as the \texttt{Effects} library 252 | permits introduction of additional effects within an effectful computation. 253 | 254 | Handlers may only be associated with a form if they have argument types 255 | corresponding to the types associated with the form elements. Additionally, we 256 | wish to name the function in order for it to be serialised, whilst requiring a 257 | proof that the specified name is associated with the function. If this were not 258 | required, it would be possible to use a function satisfying the type 259 | requirement, without guaranteeing that the serialised data corresponded to 260 | that function. 261 | 262 | We may specify a handler function of type \texttt{FormHandler}: 263 | 264 | \begin{SaveVerbatim}{formhandler} 265 | 266 | FormHandler : List EFFECT -> Type 267 | FormHandler effs = Eff IO effs () 268 | 269 | \end{SaveVerbatim} 270 | \useverb{formhandler} 271 | 272 | \noindent 273 | In order to associate a handler with a form, we call the \texttt{addSubmit} 274 | function: 275 | 276 | \begin{SaveVerbatim}{addsubmit} 277 | 278 | addSubmit : (f : mkHandlerFn ((reverse G), E)) -> 279 | (fns : HandlerList) -> 280 | {default tactics 281 | { applyTactic findFn 100; solve; } 282 | prf : FnElem f fns} -> 283 | EffM m [FORM (FormRes G E)] 284 | [FORM (FormRes [] [])] 285 | String 286 | addSubmit f handlers {prf} = (Submit f name) 287 | where name : String 288 | name = getString' f handlers prf 289 | 290 | \end{SaveVerbatim} 291 | \useverb{addsubmit} 292 | 293 | \noindent 294 | This function takes a handler function and a list of available handlers, along with 295 | an automatically constructed proof (using the \texttt{default} argument) that the 296 | handler is available. 297 | Let us look at each aspect of this function in turn. Firstly, the 298 | \texttt{mkHandlerFn} function calculates the required type of the handler 299 | function from the list of types associated with the form elements, and the 300 | effects we specified with \texttt{useEffects}. Note that since we prepend types 301 | to the list of \texttt{FormTy}s as opposed to appending them, we must reverse 302 | the list of form elements \texttt{G}. 303 | 304 | \begin{SaveVerbatim}{mkhandlerfnty} 305 | 306 | MkHandlerFnTy : Type 307 | MkHandlerFnTy = (List FormTy, List WebEffect) 308 | 309 | \end{SaveVerbatim} 310 | 311 | \begin{SaveVerbatim}{mkhandlerfnp} 312 | 313 | mkHandlerFn' : List FormTy -> List WebEffect -> Type 314 | mkHandlerFn' [] effs = FormHandler (map webEffect effs) 315 | mkHandlerFn' (x :: xs) effs = Maybe (interpFormTy x) -> 316 | mkHandlerFn' xs effs 317 | \end{SaveVerbatim} 318 | 319 | \begin{SaveVerbatim}{mkhandlerfn} 320 | mkHandlerFn : MkHandlerFnTy -> Type 321 | mkHandlerFn (tys, effs) = mkHandlerFn' tys effs 322 | 323 | \end{SaveVerbatim} 324 | 325 | \useverb{mkhandlerfnty} 326 | 327 | \useverb{mkhandlerfnp} 328 | 329 | \useverb{mkhandlerfn} 330 | 331 | \noindent 332 | The \texttt{mkHandlerFn} function takes a tuple describing the arguments and 333 | web effects available to the handler function. When constructing the function 334 | type, we wrap all arguments in a \texttt{Maybe}, in order to handle 335 | failure should the supplied data fail to parse as the required type. 336 | % 337 | To store a reference to a handler function, we use the \texttt{HandlerFn} type: 338 | 339 | \begin{SaveVerbatim}{handlerfn} 340 | 341 | HandlerFn : Type 342 | HandlerFn = (ft ** (mkHandlerFn ft, String)) 343 | 344 | \end{SaveVerbatim} 345 | \useverb{handlerfn} 346 | 347 | \noindent 348 | The \texttt{**} notation denotes a dependent pair, in which the type of the second 349 | element of the pair is parameterised over the value of the first element. It is 350 | an existential binding: 351 | the notation \texttt{(x ** P x)} can be read as ``there exists an \texttt{x} such that 352 | \texttt{P x} holds''. 353 | Therefore a \texttt{HandlerFn} states that there exists a function type 354 | \texttt{ft} such that we have a handler for it, and a unique string identifier 355 | which is used to serialise a 356 | reference to the handler function. 357 | 358 | In order to abstract away from this implementation detail, we make use of 359 | \idris{} syntax rewriting rules. This allows us to define the following: 360 | 361 | \noindent 362 | \begin{SaveVerbatim}{syntaxhandler} 363 | 364 | syntax 365 | "handler args=" [args] ", effects=" [effs] ", fn=" [fn] 366 | ", name=" [name] = ((args, effs) ** (fn, name)) 367 | 368 | \end{SaveVerbatim} 369 | \useverb{syntaxhandler} 370 | 371 | \noindent 372 | We may then define handlers in a more readable fashion, without being 373 | concerned with the implementation details. This allows us to write a handler 374 | with one String argument, making use of the CGI effect, associated with the 375 | \texttt{echo} handler function as follows: 376 | 377 | \begin{SaveVerbatim}{handlerex} 378 | 379 | handler args=[FormString], 380 | effects=[CgiEffect], 381 | fn=echo, 382 | name="echo" 383 | 384 | \end{SaveVerbatim} 385 | \useverb{handlerex} 386 | 387 | \noindent 388 | We then store each \texttt{HandlerFn} in a \texttt{HandlerList}. 389 | 390 | \begin{SaveVerbatim}{handlerlist} 391 | 392 | HandlerList : Type 393 | HandlerList = List HandlerFn 394 | 395 | \end{SaveVerbatim} 396 | \useverb{handlerlist} 397 | 398 | \noindent 399 | To enforce the requirement that a supplied handler function must be in the 400 | list of available handlers, and therefore allow us to retrieve the name with 401 | which to serialise the handler, we require a \textit{list membership proof}, 402 | \texttt{FnElem f fns}, which statically guarantees that a given item resides in 403 | a list. 404 | 405 | \begin{SaveVerbatim}{fnelem} 406 | 407 | using (xs : HanderList , f : mkHandler (reverse G, E)) 408 | data FnElem : mkHandlerFn ((reverse G), E) -> 409 | HandlerList -> Type where 410 | FnHere : FnElem f (((reverse G, E) ** 411 | (f, fStr)) :: xs) 412 | FnThere : FnElem f xs -> FnElem f (x :: xs) 413 | 414 | \end{SaveVerbatim} 415 | \useverb{fnelem} 416 | 417 | \noindent 418 | \texttt{FnElem} is parameterised over \texttt{G} and \texttt{E}, the types of the 419 | form elements and the effects used by the handler function. \texttt{FnHere} 420 | is a proof that the element is at the head of the current point of the list, 421 | whereas \texttt{FnThere} is a proof that the element is in the tail of 422 | the list. 423 | We then use an automatic proof search to 424 | generate the proof at compile time, should one exist. The proof 425 | may then be used in subsequent computations: we use it to retrieve 426 | the unique identifier for the function. If the automated proof search fails, 427 | compilation will fail. 428 | 429 | Finally, we serialise the argument types, supported effects, and return 430 | type of the handler, to allow the form data to be 431 | deserialised and ensure that the correct handler is executed on the 432 | server. 433 | 434 | Although sending details of the handler function to the client may appear to be 435 | a security risk, we envisage that the use of symmetric encryption or a 436 | cryptographic nonce would mitigate this. Ultimately, we hope to implement a 437 | web server with persistent state, which would eliminate the need for 438 | serialisation altogether. 439 | 440 | Running form construction is achieved as an operation of the \texttt{CGI} 441 | effect, \texttt{AddForm}, which then outputs the generated HTML to the page. 442 | The generated metadata describing the handler function is serialised as a 443 | hidden HTML field. 444 | 445 | \subsection{Form Handling} 446 | \label{formhandling} 447 | Once the form has been submitted, a web application may handle the submitted 448 | data by invoking \texttt{HandleForm}. This will check for the 449 | existence of the hidden \texttt{handler} field, which contains the previously 450 | serialised metadata about the form handler, before deserialising the 451 | data into a \texttt{MkHandlerFnTy}. 452 | 453 | With this data, we then look up the function in the list of registered 454 | handlers by using the unique handler identifier. In order to apply 455 | the handler function to the data submitted in the form, we must first prove to 456 | the type checker that the deserialised \texttt{MkHandlerFnTy} is the same as 457 | the one retrieved from the list of registered handlers. We do this by making 458 | use of the \texttt{decEq} function, which determines whether two types are 459 | equal, returning a proof of equality if so, and a proof of inequality if not. 460 | 461 | \begin{SaveVerbatim}{deceqty} 462 | 463 | decEq : DecEq t => (x : t) -> (y : t) -> Dec (x = y) 464 | 465 | \end{SaveVerbatim} 466 | \useverb{deceqty} 467 | 468 | We then use the \texttt{with} construct, inspired by 469 | \textit{views} in Epigram \cite{mcbride.mckinna:viewfromleft}, to rewrite the 470 | arguments on the left hand side. This allows us to construct a function which, 471 | given the stored handler, the data required to 472 | construct the function type and the \texttt{MkHandlerFnTy} deserialised from 473 | the form, determines whether the two \texttt{MkHandlerFnTy}s are decidably 474 | equal. If so, we rewrite this on the left hand side since the equality proof 475 | demonstrates that the recorded function may also be used to handle the form 476 | data. If not, the computation fails. 477 | 478 | \begin{SaveVerbatim}{checkfunctionsty} 479 | 480 | checkFunctions : (reg_fn_ty : MkHandlerFnTy) -> 481 | (frm_fn_ty : MkHandlerFnTy) -> 482 | mkHandlerFn reg_fn_ty -> 483 | Maybe (mkHandlerFn frm_fn_ty) 484 | \end{SaveVerbatim} 485 | 486 | \begin{SaveVerbatim}{checkfunctions} 487 | checkFunctions reg_ty frm_ty reg_fn with 488 | (decEq reg_ty frm_ty) 489 | checkFunctions frm_ty frm_ty reg_fn 490 | | Yes refl = Just reg_fn 491 | checkFunctions reg_ty frm_ty reg_fn 492 | | No _ = Nothing 493 | 494 | \end{SaveVerbatim} 495 | 496 | \useverb{checkfunctionsty} 497 | 498 | \useverb{checkfunctions} 499 | 500 | \noindent 501 | We may then parse the arguments according to the types specified by the handler 502 | function, and then apply the arguments to the handler function. 503 | Finally, we may run the handler function, ensuring that 504 | all updates made to the CGI state are propagated. 505 | 506 | %----------------------------- 507 | %----------------------------- -------------------------------------------------------------------------------- /paper/introduction.tex: -------------------------------------------------------------------------------- 1 | \section{Introduction} 2 | 3 | Web applications, whilst ubiquitous, are also prone to incorrect construction 4 | and security exploits such as SQL injection \cite{owasp:sqli} or cross-site 5 | scripting \cite{owasp:xss}. Security breaches are 6 | far-reaching, and high profile cases involve large corporations such as Sony, 7 | who suffered a well-publicised and extremely costly SQL injection breach in 8 | 2011 \cite{ieee:sony}, and \textit{Yahoo!}, who suffered a breach in 2012 9 | \cite{imperva:yahoo}. 10 | 11 | Many web applications are written in dynamically-checked scripting languages 12 | such as PHP, Ruby or Python, which facilitate rapid development 13 | \cite{w3techs:webpls}. Such languages do not, however, provide the same static 14 | guarantees about runtime behaviour afforded by 15 | programs with more expressive, static type systems, instead relying on 16 | extensive unit testing to ensure correctness and security. 17 | 18 | %%------- EXAMPLE 19 | Let us consider a simple database access routine, written in 20 | PHP, where we wish to obtain the name and address of every employee working in 21 | a given department, \texttt{\$dept}. We firstly construct an object 22 | representing a database connection, where the arguments are the database host, 23 | user, password and name respectively: 24 | 25 | \begin{SaveVerbatim}{conn} 26 | 27 | $conn = new mysqli("localhost", "username", 28 | "password", "db"); 29 | 30 | \end{SaveVerbatim} 31 | \useverb{conn} 32 | 33 | \noindent 34 | We should then check to see if the connection was successful, and exit 35 | if not: 36 | %This check is optional, so 37 | %it would be possible to omit it. However, this would cause 38 | %problems with later steps. 39 | 40 | \begin{SaveVerbatim}{connerr} 41 | 42 | if (mysqli_connect_errno()) { exit(); } 43 | 44 | \end{SaveVerbatim} 45 | \useverb{connerr} 46 | 47 | \noindent 48 | We then create a prepared statement detailing our query, and bind the 49 | \texttt{`dept'} value: 50 | 51 | \begin{SaveVerbatim}{prepare} 52 | 53 | $stmt = $conn->prepare("SELECT `name`, `address` 54 | FROM `staff` WHERE `dept` = ?); 55 | $stmt->bind_param('s', $dept); 56 | 57 | \end{SaveVerbatim} 58 | \useverb{prepare} 59 | 60 | \noindent 61 | After the parameters have been bound, we execute the statement, assign 62 | variables into which results will be stored, and fetch each row in turn. 63 | Failure to execute a statement before attempting to fetch rows would cause an error, as would attempting to execute a statement without binding variables to it. 64 | 65 | \begin{SaveVerbatim}{stmtexec} 66 | 67 | $stmt->execute(); 68 | $stmt->bind_result($name, $address); 69 | while ($stmt->fetch()) { 70 | printf("Name: %s, Age: %s", $name, $age); 71 | } 72 | 73 | \end{SaveVerbatim} 74 | \useverb{stmtexec} 75 | 76 | \noindent 77 | Finally, once the statement and connection are no longer needed, they should be 78 | closed in order to discard the associated resources: 79 | 80 | \begin{SaveVerbatim}{connclose} 81 | 82 | $stmt->close(); 83 | $conn->close(); 84 | 85 | \end{SaveVerbatim} 86 | \useverb{connclose} 87 | 88 | \noindent 89 | Even in this small example, there exists a precise resource usage protocol 90 | which must be followed for successful and robust operation. 91 | Firstly, a connection to the database must be opened. The object-oriented style 92 | used in the example encapsulates this to an extent, as the object must be 93 | created in order for operations to be performed, however it is less obvious in 94 | a procedural version of the code. Secondly, a prepared statement is created, 95 | using the raw SQL and placeholders to which variables are later bound. The 96 | statement is then executed, and each row is retrieved from the database. 97 | Finally, the resources are freed. 98 | 99 | Problems may arise if the protocol is not followed correctly. 100 | A developer may, for example, accidentally close a statement whilst still 101 | retrieving rows, which would cause a runtime error. Similarly, a developer may 102 | omit closing the statement or connection, which can lead to 103 | problems such as resource leaks in longer-running server applications. 104 | However, in conventional programming languages, there is no way to check 105 | automatically, at compile-time, that a protocol is followed. 106 | 107 | In contrast, the use of \textit{dependent types} makes it possible 108 | to specify a program's behaviour precisely, and to check that a 109 | specification is followed. 110 | % 111 | Unfortunately, automatic verification by a compiler can be difficult or 112 | often impossible, requiring additional proofs to be given by the developer. 113 | 114 | This complexity can be addressed through the use of \textit{embedded 115 | domain-specific languages} (EDSLs) to abstract away the complexity of the 116 | underlying type system. Embedding a domain-specific language in 117 | a dependently typed host language 118 | allows domain experts to write 119 | domain-specific code, with the EDSL itself used to provide the proof that the 120 | code is correct. 121 | 122 | \idris{} \cite{brady2013idris} is a language with full dependent types, and 123 | extensive support for EDSLs through overloading and syntax macros. Through the 124 | use of \idris{}, and a framework for describing resource protocols using 125 | \emph{algebraic effects}~\cite{brady:effects}, we 126 | present a dependently-typed web framework allowing the construction of 127 | programs with additional guarantees about correctness and security, whilst 128 | minimising the increase in development complexity. 129 | 130 | \subsection{Contributions} 131 | The primary contribution of this paper is the application of 132 | dependent types to provide strong static guarantees 133 | about the correctness and security of web applications, whilst minimising 134 | additional development complexity. In particular, we present: 135 | 136 | \begin{itemize} 137 | \item Representations of CGI, Databases and sessions as 138 | \textit{resource-dependent algebraic effects}, allowing programs to be accepted 139 | only when they follow clearly defined resource usage protocols. 140 | (Section~\ref{rup}) 141 | 142 | \item Type-safe form handling, preserving type information and managing 143 | user input, therefore increasing applications' resilience to attacks such as 144 | SQL injection and cross-site scripting. (Section~\ref{form}) 145 | 146 | \item An extended example: a message board application, demonstrating the usage 147 | of the framework in practice. (Section~\ref{effects}) 148 | 149 | \end{itemize} 150 | 151 | We achieve these without extending the host language. Every 152 | resource protocol we implement is pure \Idris{}, using a library for 153 | resource-dependent algebraic effects~\cite{brady:effects} and \Idris{}' 154 | features for supporting domain-specific language implementation such as 155 | syntax macros and overloading. In particular, this means the same techniques 156 | can be applied to other resources, and most importantly, combinations 157 | of resources and DSLs implemented in this way are \emph{composable}. 158 | 159 | %We structure the remainder of this paper as follows. We provide a brief 160 | %overview of the \texttt{Effects} framework in Section ~\ref{effects}; explain 161 | %how this may be used to ensure adherence to resource usage protocols for CGI, 162 | %SQLite and a session handler in Section ~\ref{rup}; describe an EDSL for 163 | %type-safe form handling in Section ~\ref{form}, implemented using 164 | %\texttt{Effects}; and discuss the larger example 165 | %of a message board system making use of these components in Section 166 | %~\ref{messageboard}. 167 | 168 | The code used to implement the framework and all associated examples used in 169 | this paper is available online at 170 | \url{http://www.github.com/idris-hackers/IdrisWeb}. 171 | 172 | % ================================================= 173 | % ================================================= -------------------------------------------------------------------------------- /paper/main.tex: -------------------------------------------------------------------------------- 1 | %----------------------------------------------------------------------------- 2 | % 3 | % Template for sigplanconf LaTeX Class 4 | % 5 | % Name: sigplanconf-template.tex 6 | % 7 | % Purpose: A template for sigplanconf.cls, which is a LaTeX 2e class 8 | % file for SIGPLAN conference proceedings. 9 | % 10 | % Guide: Refer to "Author's Guide to the ACM SIGPLAN Class," 11 | % sigplanconf-guide.pdf 12 | % 13 | % Author: Paul C. Anagnostopoulos 14 | % Windfall Software 15 | % 978 371-2316 16 | % paul@windfall.com 17 | % 18 | % Created: 15 February 2005 19 | % 20 | %----------------------------------------------------------------------------- 21 | 22 | 23 | \documentclass[]{sigplanconf} 24 | 25 | % The following \documentclass options may be useful: 26 | 27 | % preprint Remove this option only once the paper is in final form. 28 | % 10pt To set in 10-point type instead of 9-point. 29 | % 11pt To set in 11-point type instead of 9-point. 30 | % authoryear To obtain author/year citation style instead of numeric. 31 | 32 | \usepackage{amsmath} 33 | %\usepackage{silence} 34 | \usepackage{pgf} 35 | \usepackage{tikz} 36 | \usetikzlibrary{arrows,automata} 37 | \usepackage{url} 38 | \usepackage[hidelinks]{hyperref} 39 | \usepackage{fancyvrb} 40 | \usepackage[numbers]{natbib} 41 | \usepackage{microtype} 42 | %\WarningsOff 43 | 44 | \newcommand{\useverbtb}[1]{\begin{tiny}\BUseVerbatim{#1}\end{tiny}} 45 | \newcommand{\useverb}[1]{\begin{small}\BUseVerbatim{#1}\end{small}} 46 | \newcommand{\useverbb}[1]{\begin{small}\BUseVerbatim{#1}\end{small}} 47 | 48 | \begin{document} 49 | \fvset{fontsize=\small} 50 | \newcommand{\idris}{\textsc{Idris}} 51 | \newcommand{\idata}{\textsf{iData}} 52 | \newcommand{\itasks}{\textsf{iTasks}} 53 | \newcommand{\Idris}{\textsc{Idris}} 54 | \special{papersize=8.5in,11in} 55 | \setlength{\pdfpageheight}{\paperheight} 56 | \setlength{\pdfpagewidth}{\paperwidth} 57 | 58 | \exclusivelicense 59 | \conferenceinfo{IFL '13}{August 28--31, 2013, Nijmegen, The Netherlands} 60 | \copyrightyear{2013} 61 | \copyrightdata{978-1-nnnn-nnnn-n/yy/mm} 62 | \doi{nnnnnnn.nnnnnnn} 63 | 64 | % Uncomment one of the following two, if you are not going for the 65 | % traditional copyright transfer agreement. 66 | 67 | %\exclusivelicense % ACM gets exclusive license to publish, 68 | % you retain copyright 69 | 70 | %\permissiontopublish % ACM gets nonexclusive license to publish 71 | % (paid open-access papers, 72 | % short abstracts) 73 | 74 | %\authorversion 75 | 76 | \titlebanner{} % These are ignored unless 77 | \preprintfooter{} % 'preprint' option specified. 78 | 79 | \title{Dependent Types for Safe and Secure Web Programming} 80 | \authorinfo{Simon Fowler \and Edwin Brady} 81 | {School of Computer Science, University of St Andrews, St Andrews, Scotland} 82 | {Email: \{sf37, ecb10\}@st-andrews.ac.uk} 83 | 84 | \maketitle 85 | 86 | \begin{abstract} 87 | Dependently-typed languages allow precise types to be used during development, 88 | facilitating static reasoning about program behaviour. However, 89 | with the use of more specific types comes the disadvantage that it becomes increasingly difficult to 90 | write programs that are accepted by a type checker, meaning additional proofs may have to be specified manually. 91 | 92 | Embedded domain-specific languages (EDSLs) can help address this problem by 93 | introducing a layer of abstraction over more precise underlying types, 94 | allowing domain-specific code to be written in a verified high-level language without imposing additional proof 95 | obligations on an application developer. 96 | 97 | In this paper, we apply this technique to web programming. Using the 98 | dependently typed programming language \Idris{}, we show how to use EDSLs to enforce resource usage protocols associated with common web operations such as CGI, database access and session handling. We also introduce an EDSL which uses dependent types to facilitate the creation and handling of web forms, reducing the scope for programmer error and possible security implications. 99 | 100 | \end{abstract} 101 | 102 | \category{D.3.2}{Programming Languages}{Language Classifications---Applicative (functional) Languages} 103 | 104 | % general terms are not compulsory anymore, 105 | % you may leave them out 106 | %\terms 107 | %term1, term2 108 | 109 | \keywords 110 | Dependent Types, Web Applications, Verification 111 | %keyword1, keyword2 112 | 113 | \input{introduction} 114 | \input{effects} 115 | \input{protocols} 116 | \input{forms} 117 | \input{messageboard} 118 | \input{conclusion} 119 | 120 | %\appendix 121 | %\section{Appendix Title} 122 | 123 | %This is the text of the appendix, if you need one. 124 | 125 | %----------------------------- 126 | %----------------------------- 127 | 128 | \acks 129 | This work has been supported by the Scottish Informatics and Computer Science Alliance (SICSA) and the EPSRC. We would like to thank the contributors to the \idris{} language, especially the authors of the original \texttt{Network.Cgi} and \texttt{SQLite} libraries. 130 | We are very grateful to Peter Thiemann and the anonymous reviewers for their insightful and constructive comments and suggestions. 131 | % SICSA / EPSRC (grant number? 132 | % #idris 133 | % Idris contributors, in particular Melissa for the SQLite bindings and whoever wrote Network.Cgi 134 | 135 | % We recommend abbrvnat bibliography style. 136 | 137 | \bibliographystyle{plainnat} 138 | 139 | % The bibliography should be embedded for final submission. 140 | 141 | \bibliography{refs} 142 | %\begin{thebibliography}{} 143 | %\softraggedright 144 | % 145 | %\bibitem[Smith et~al.(2009)Smith, Jones]{smith02} 146 | %P. Q. Smith, and X. Y. Jones. ...reference text... 147 | % 148 | %\end{thebibliography} 149 | 150 | 151 | \end{document} 152 | 153 | % Revision History 154 | % -------- ------- 155 | % Date Person Ver. Change 156 | % ---- ------ ---- ------ 157 | 158 | % 2013.06.29 TU 0.1--4 comments on permission/copyright notices -------------------------------------------------------------------------------- /paper/messageboard.tex: -------------------------------------------------------------------------------- 1 | \section{Extended Example: Message Board} 2 | \label{messageboard} 3 | In this section we consider a larger example---a message board application 4 | which allows users to register, log in, view and create threads, and list and 5 | create new posts in threads. 6 | 7 | Firstly, we create a database schema in which to record information stored by 8 | the message board. We create three tables: \texttt{Users}, which contains a 9 | unique User ID, usernames and passwords; \texttt{Threads}, which contains a 10 | unique thread ID, a title, and the ID of the user who created the thread; and 11 | \texttt{Posts}, which contains a unique post ID, the ID of the thread to which 12 | each post belongs, the content of the post, and the ID of the user that created 13 | the post. 14 | 15 | Secondly, we use a \texttt{GET} variable, \texttt{action}, to indicate which page of the 16 | message board should be displayed, and pattern-match on these to call the 17 | appropriate function which displays the page. Some pages, such as the page 18 | which shows all of the posts in a thread, require a second argument, 19 | \texttt{thread\_id}. 20 | 21 | \subsection{Handling requests} 22 | The entry point to any CGI application is the \texttt{main} function. From 23 | here, we run the remainder of the program through a call to \texttt{runCGI}, 24 | which we initialise with empty initial environments for the \texttt{CGI}, 25 | \texttt{Session} and 26 | \texttt{SQLite} effects, so they may be used in further computations. 27 | 28 | \begin{SaveVerbatim}{msgmain} 29 | 30 | main : IO () 31 | main = runCGI [initCGIState, InvalidSession, ()] 32 | handleRequest 33 | 34 | \end{SaveVerbatim} 35 | \useverb{msgmain} 36 | 37 | \noindent 38 | We define a function, \texttt{handleRequest}, which firstly determines 39 | whether submitted form data must be handled, by checking whether a handler 40 | variable exists. 41 | If so, then the form handling routine is called, which executes the 42 | corresponding handler function as specified in Section ~\ref{formhandling}. If 43 | not, then the \texttt{handleNonFormRequest} function is called, which inspects 44 | the \texttt{GET} variables in order to display the correct page. 45 | 46 | \begin{SaveVerbatim}{handlereq} 47 | handleRequest : 48 | CGIProg [SESSION (SessionRes SessionUninitialised), 49 | SQLITE ()] () 50 | handleRequest = do 51 | handler_set <- isHandlerSet 52 | if handler_set then do 53 | handleForm handlers 54 | return () 55 | else do 56 | action <- queryGetVar "action" 57 | thread_id <- queryGetVar "thread_id" 58 | handleNonFormRequest action (map strToInt thread_id) 59 | 60 | \end{SaveVerbatim} 61 | \useverb{handlereq} 62 | 63 | \subsection{Thread Creation} 64 | We create four forms: one to handle registration, one to handle logging in, 65 | one to handle the creation of new threads, and one to handle the creation of 66 | new posts. For example, the form used to create a new thread 67 | contains elements for the title of the new thread and the content of the 68 | first post of the new thread: 69 | 70 | \begin{SaveVerbatim}{newthread} 71 | 72 | newThreadForm : UserForm 73 | newThreadForm = do 74 | addTextBox "Title" FormString Nothing 75 | addTextBox "Post Content" FormString Nothing 76 | useEffects [CgiEffect, SessionEffect, SqliteEffect] 77 | addSubmit handleNewThread handlers 78 | 79 | \end{SaveVerbatim} 80 | \useverb{newthread} 81 | 82 | \noindent 83 | This consists of two text boxes: one for the title of the thread, and one 84 | for the content of the first post. Both are of type \texttt{String}, as denoted 85 | by the \texttt{FormString} argument, and both have no default value. The 86 | handler function may make use of the \texttt{CGI}, \texttt{SESSION} and 87 | \texttt{SQLITE} effects, and the handler function is specified as 88 | \texttt{handleNewThread}. The \texttt{handlers} argument refers to the list of 89 | form handlers, and is of the following form: 90 | 91 | \begin{SaveVerbatim}{msghandlers} 92 | 93 | handlers : HandlerList 94 | handlers = [ 95 | (handler args=[FormString, FormString], 96 | effects=[CgiEffect, SessionEffect, SqliteEffect], 97 | fn=handleRegisterForm, 98 | name="handleRegisterForm"), 99 | 100 | (handler args=[FormString, FormString], 101 | effects=[CgiEffect, SessionEffect, SqliteEffect], 102 | fn=handleNewThread, 103 | name="handleNewThread"), 104 | ...] 105 | 106 | \end{SaveVerbatim} 107 | \noindent 108 | \useverb{msghandlers} 109 | 110 | \noindent 111 | Creating a new thread (shown in Figure \ref{fig:handlethread}) 112 | requires a user to be logged in, so that the thread 113 | starter may be recorded in the database. In order to do this, we make use of 114 | the session handler. We define a function \texttt{withSession}, which attempts 115 | to retrieve the session associated with the current request, and if it exists, 116 | executes a function which is passed the associated session data. If not, then a 117 | failure function is called instead. Should the form handler function be called 118 | with invalid arguments, an error is shown. 119 | 120 | \begin{SaveVerbatim}{handlenewthread} 121 | handleNewThread : 122 | Maybe String -> Maybe String -> 123 | FormHandler [CGI (InitialisedCGI TaskRunning), 124 | SESSION (SessionRes SessionUninitialised), 125 | SQLITE ()] 126 | handleNewThread (Just title) (Just content) = do 127 | withSession (addNewThread title content) notLoggedIn 128 | return () 129 | handleNewThread _ _ = do 130 | outputWithPreamble "

Error


There was 131 | an error posting your thread." 132 | return () 133 | \end{SaveVerbatim} 134 | 135 | \begin{figure}[h] 136 | \useverb{handlenewthread} 137 | \caption{Thread Creation} 138 | \label{fig:handlethread} 139 | \end{figure} 140 | 141 | Once we have loaded the session data from the database, we then check whether 142 | the \texttt{UserID} variable is set, which demonstrates that a user has 143 | successfully logged into the system, and allows us to use the ID in subsequent 144 | computations. The database operation to insert the thread into the database is 145 | performed by \texttt{threadInsert}, shown in Figure \ref{fig:threadins}. 146 | 147 | This uses a library function \texttt{executeInsert}, which abstracts over the 148 | low-level resource usage protocol, enabling for provably-correct database 149 | access without the additional DSL code. In addition, \texttt{executeInsert} 150 | returns the unique row ID of the last item which was inserted, which may be 151 | used in subsequent computations. In the case of the message board, we use this 152 | to associate the first post of the thread with the thread being inserted. 153 | 154 | \begin{SaveVerbatim}{threadins} 155 | threadInsert : Int -> String -> String -> 156 | Eff IO [SQLITE ()] Bool 157 | threadInsert uid title content = do 158 | let query = "INSERT INTO `Threads` 159 | (`UserID`, `Title`) VALUES (?, ?)" 160 | insert_res <- (executeInsert DB_NAME query 161 | [(1, DBInt uid), (2, DBText title)] 162 | case insert_res of 163 | Left err => return False 164 | Right thread_id => postInsert uid thread_id content 165 | \end{SaveVerbatim} 166 | 167 | \begin{figure}[h] 168 | \useverb{threadins} 169 | \caption{Thread Insertion} 170 | \label{fig:threadins} 171 | \end{figure} 172 | 173 | \subsection{Listing Threads} 174 | 175 | Listing the threads in the database is achieved using 176 | \texttt{executeSelect}, which returns either a 177 | \texttt{ResultSet} or an error: 178 | 179 | \begin{SaveVerbatim}{getthreads} 180 | 181 | getThreads : Eff IO [SQLITE ()] (Either String ResultSet) 182 | getThreads = 183 | executeSelect DB_NAME query [] collectThreadResults 184 | where query = "SELECT `ThreadID`, `Title`, `UserID`, 185 | `Username` FROM `Threads` NATURAL JOIN `Users`" 186 | 187 | \end{SaveVerbatim} 188 | \noindent 189 | \useverb{getthreads} 190 | 191 | \noindent 192 | Once the result set has been retrieved, we may iterate through the 193 | results and output them to the page, including a link to a page which shows the 194 | posts associated with the thread. This is shown in Figure \ref{fig:traverse}. 195 | Since we know the structure of the returned 196 | row from designing the query, we may pattern match on each returned row to make 197 | use of the returned values. 198 | 199 | \begin{SaveVerbatim}{traversethreads} 200 | traverseThreads : ResultSet -> 201 | Eff IO [CGI (InitialisedCGI TaskRunning)] () 202 | traverseThreads [] = return () 203 | traverseThreads (x::xs) = do traverseRow x 204 | traverseThreads xs 205 | where traverseRow : List DBVal -> 206 | Eff IO [CGI (InitialisedCGI TaskRunning)] () 207 | traverseRow ((DBInt thread_id):: 208 | (DBText title):: 209 | (DBInt user_id):: 210 | (DBText username)::[]) = 211 | (output $ " 212 | " ++ 214 | title ++ "" ++ 215 | username ++ "") 216 | traverseRow _ = return () 217 | \end{SaveVerbatim} 218 | 219 | \begin{figure}[h] 220 | \useverb{traversethreads} 221 | \caption{Listing Threads} 222 | \label{fig:traverse} 223 | \end{figure} 224 | 225 | \subsection{Authentication} 226 | 227 | Once a user submits the login form, the associated handler queries the database 228 | to ascertain whether a user with the given username and password exists through 229 | a call to the \texttt{authUser} function. This is shown in Figure 230 | \ref{fig:handlelogin}. If so, then the session handler is 231 | invoked, and a session is initialised with the user ID retrieved from the 232 | database. The session ID is then set as a cookie using the CGI effect, so that 233 | it may be used in subsequent requests. Any failures, for example with creating 234 | a new session or querying the database, are reported to the user. 235 | Implementations for the insertion and display of posts, alongside registration, 236 | follow the same structure. 237 | 238 | \begin{SaveVerbatim}{handlelogin} 239 | handleLoginForm (Just name) (Just pwd) = do 240 | auth_res <- (authUser name pwd) 241 | case auth_res of 242 | Right (Just uid) => do 243 | set_sess_res <- setSession uid 244 | if set_sess_res then do 245 | output $ "Welcome, " ++ name 246 | return () 247 | else do 248 | output "Could not set session" 249 | return () 250 | Right Nothing => do 251 | output "Invalid username or password" 252 | return () 253 | Left err => do 254 | output $ "Error: " ++ err 255 | return () 256 | \end{SaveVerbatim} 257 | 258 | \begin{figure}[h] 259 | \useverb{handlelogin} 260 | \caption{Authentication} 261 | \label{fig:handlelogin} 262 | \end{figure} 263 | 264 | Although we have described a relatively simple application, we have shown that 265 | through the use of embedded domain-specific languages, 266 | and particularly by encapsulating resource usage protocols in the types, 267 | we can write verified 268 | code that fails to compile should resources be incorrectly accessed. 269 | Additionally, we have used the form handling mechanism to simply handle the 270 | arguments passed by the user. Importantly, we have shown that dependent types 271 | can be used to increase confidence in an (albeit simplified) real-world 272 | application, without requiring developers to supply proofs. 273 | 274 | %----------------------------- 275 | %----------------------------- -------------------------------------------------------------------------------- /paper/refs.bib: -------------------------------------------------------------------------------- 1 | % This file was created with JabRef 2.10b. 2 | % Encoding: UTF-8 3 | 4 | @inproceedings{Plotkin2009, 5 | author = {Plotkin, Gordon and Pretnar, Matija}, 6 | booktitle = {ESOP ’09: Proceedings of the 18th European Symposium on Programming Languages and Systems}, 7 | file = {:Users/edwin/Downloads/10.1007_978-3-642-00590-9_7:1007_978-3-642-00590-9_7}, 8 | pages = {80----94}, 9 | title = {{Handlers of Algebraic Effects}}, 10 | year = {2009} 11 | } 12 | 13 | @InCollection{jpa, 14 | Title = {{Java Persistence API}}, 15 | Author = {B{\"o}ck, Heiko}, 16 | Booktitle = {The Definitive Guide to NetBeans Platform 7}, 17 | Publisher = {Springer}, 18 | Year = {2011}, 19 | Pages = {315--320}, 20 | 21 | Owner = {sf37}, 22 | Timestamp = {2013.07.31} 23 | } 24 | 25 | @Electronic{bbc:sony, 26 | Title = {Sony investigating another hack}, 27 | Author = {{BBC News}}, 28 | Month = {June}, 29 | Url = {http://www.bbc.co.uk/news/business-13636704}, 30 | Year = {2011}, 31 | 32 | Owner = {sf37}, 33 | Timestamp = {2013.07.30} 34 | } 35 | 36 | @InCollection{brady:edsl, 37 | Title = {Resource-safe systems programming with embedded domain specific languages}, 38 | Author = {Brady, Edwin and Hammond, Kevin}, 39 | Booktitle = {Practical Aspects of Declarative Languages}, 40 | Publisher = {Springer}, 41 | Year = {2012}, 42 | Pages = {242--257}, 43 | 44 | Owner = {sf37}, 45 | Timestamp = {2013.07.31} 46 | } 47 | 48 | @Conference{brady:effects, 49 | Title = {{Programming and Reasoning with Algebraic Effects and Dependent Types}}, 50 | Author = {Edwin Brady}, 51 | Booktitle = {Proceedings of the 18th ACM SIGPLAN International Conference on Functional Programming}, 52 | Year = {2013}, 53 | Note = {To appear.}, 54 | 55 | Owner = {sf37}, 56 | Timestamp = {2013.07.27} 57 | } 58 | 59 | @article{brady2013idris, 60 | author = {Edwin Brady}, 61 | title = {{Idris, a general-purpose dependently typed programming language: Design and implementation}}, 62 | journal = {Journal of Functional Programming}, 63 | volume = {23}, 64 | issue = {05}, 65 | month = {9}, 66 | year = {2013}, 67 | issn = {1469-7653}, 68 | pages = {552--593}, 69 | numpages = {42}, 70 | doi = {10.1017/S095679681300018X} 71 | } 72 | 73 | @InProceedings{brady2011idris, 74 | Title = {{IDRIS---: systems programming meets full dependent types}}, 75 | Author = {Brady, Edwin}, 76 | Booktitle = {Proceedings of the 5th ACM workshop on Programming languages meets program verification}, 77 | Year = {2011}, 78 | Organization = {ACM}, 79 | Pages = {43--54}, 80 | 81 | Owner = {sf37}, 82 | Timestamp = {2013.07.27} 83 | } 84 | 85 | @inproceedings{urweb, 86 | author = {Chlipala, Adam}, 87 | title = {{Ur}: Statically-typed Metaprogramming with Type-level Record Computation}, 88 | booktitle = {Proceedings of the 2010 ACM SIGPLAN Conference on Programming Language Design and Implementation}, 89 | series = {PLDI '10}, 90 | year = {2010}, 91 | isbn = {978-1-4503-0019-3}, 92 | location = {Toronto, Ontario, Canada}, 93 | pages = {122--133}, 94 | numpages = {12}, 95 | doi = {10.1145/1806596.1806612}, 96 | acmid = {1806612}, 97 | publisher = {ACM}, 98 | address = {New York, NY, USA}, 99 | keywords = {dependent types, metaprogramming}, 100 | } 101 | 102 | @InProceedings{christiansen:dtp, 103 | Title = {{Dependent Type Providers}}, 104 | Author = {David Raymond Christiansen}, 105 | Booktitle = {Workshop on Generic Programming (WGP '13)}, 106 | Year = {2013}, 107 | 108 | Owner = {sf37}, 109 | Timestamp = {2013.07.31} 110 | } 111 | 112 | @Article{ieee:sony, 113 | Title = {{Security, Privacy, and Policy Roundup}}, 114 | Author = {Lee Garber}, 115 | Journal = {IEEE Security \& Privacy}, 116 | Year = {2012}, 117 | Number = {2}, 118 | Pages = {15-17}, 119 | Volume = {10}, 120 | 121 | Address = {Los Alamitos, CA, USA}, 122 | Doi = {http://doi.ieeecomputersociety.org/10.1109/MSP.2012.48}, 123 | ISSN = {1540-7993}, 124 | Owner = {sf37}, 125 | Publisher = {IEEE Computer Society}, 126 | Timestamp = {2013.07.30} 127 | } 128 | 129 | @Article{imperva:yahoo, 130 | Title = {{Lessons Learned From the Yahoo! Hack}}, 131 | Author = {{Imperva}}, 132 | Year = {2013}, 133 | 134 | Owner = {sf37}, 135 | Timestamp = {2013.07.30}, 136 | Url = {http://www.imperva.com/download.asp?id=299‎} 137 | } 138 | 139 | @Article{mcbride.mckinna:viewfromleft, 140 | Title = {The view from the left}, 141 | Author = {C. McBride and J. McKinna}, 142 | Journal = {{J}ournal of {F}unctional {P}rogramming}, 143 | Year = {2004}, 144 | Number = {1}, 145 | Pages = {69--111}, 146 | Volume = {14}, 147 | 148 | Owner = {sf37}, 149 | Timestamp = {2013.07.27} 150 | } 151 | 152 | @Article{meijer:cgi, 153 | Title = {{Server side web scripting in Haskell}}, 154 | Author = {Erik Meijer}, 155 | Journal = {Journal of Functional Programming}, 156 | Year = {2000}, 157 | 158 | Month = {1}, 159 | Pages = {1--18}, 160 | Volume = {10}, 161 | 162 | Doi = {null}, 163 | ISSN = {1469-7653}, 164 | Issue = {01}, 165 | Numpages = {18}, 166 | Owner = {sf37}, 167 | Timestamp = {2013.07.31} 168 | } 169 | 170 | @Electronic{owasp:xss, 171 | Title = {{Cross-site Scripting (XSS)}}, 172 | Author = {{OWASP}}, 173 | Url = {https://www.owasp.org/index.php/Cross-site_scripting}, 174 | 175 | Owner = {sf37}, 176 | Timestamp = {2013.07.30} 177 | } 178 | 179 | @Electronic{owasp:sqli, 180 | Title = {{SQL Injection}}, 181 | Author = {{OWASP}}, 182 | Url = {https://www.owasp.org/index.php/SQL_injection}, 183 | Year = {2013}, 184 | Owner = {sf37}, 185 | Timestamp = {2013.07.30} 186 | } 187 | 188 | @InCollection{plasmeijer:cms, 189 | Title = {{A Conference Management System based on the iData Toolkit}}, 190 | Author = {Plasmeijer, Rinus and Achten, Peter}, 191 | Booktitle = {Implementation and Application of Functional Languages}, 192 | Publisher = {Springer}, 193 | Year = {2007}, 194 | Pages = {108--125}, 195 | 196 | Owner = {sf37}, 197 | Timestamp = {2013.07.31} 198 | } 199 | 200 | @InCollection{plasmeijer:idata, 201 | Title = {{iData for the world wide web--programming interconnected web forms}}, 202 | Author = {Plasmeijer, Rinus and Achten, Peter}, 203 | Booktitle = {Functional and Logic Programming}, 204 | Publisher = {Springer}, 205 | Year = {2006}, 206 | Pages = {242--258}, 207 | 208 | Owner = {sf37}, 209 | Timestamp = {2013.07.31} 210 | } 211 | 212 | @Article{plasmeijer:itasks, 213 | Title = {{iTasks: executable specifications of interactive work flow systems for the web}}, 214 | Author = {Rinus Plasmeijer and Peter Achten and Pieter Koopman}, 215 | Journal = {SIGPLAN Not}, 216 | Year = {2007}, 217 | Pages = {141--152}, 218 | Volume = {42}, 219 | Owner = {sf37}, 220 | Timestamp = {2013.07.31} 221 | } 222 | 223 | @TechReport{msr:tp, 224 | Title = {Strongly-typed language support for internet-scale information sources}, 225 | Author = {Syme, Don and Battocchi, Keith and Takeda, Kenji and Malayeri, Donna and Fisher, Jomo and Hu, Jack and Liu, Tao and McNamara, Brian and Quirk, Daniel and Taveggia, Matteo and others}, 226 | Institution = {Microsoft Research}, 227 | Year = {2012}, 228 | Owner = {sf37}, 229 | Timestamp = {2013.07.31} 230 | } 231 | 232 | @InCollection{thiemann:wash, 233 | Title = {{WASH/CGI: Server-side web scripting with sessions and typed, compositional forms}}, 234 | Author = {Thiemann, Peter}, 235 | Booktitle = {Practical Aspects of Declarative Languages}, 236 | Publisher = {Springer}, 237 | Year = {2002}, 238 | Pages = {192--208}, 239 | Owner = {sf37}, 240 | Timestamp = {2013.07.31} 241 | } 242 | 243 | @InCollection{webdsl, 244 | Title = {{WebDSL: A case study in domain-specific language engineering}}, 245 | Author = {Visser, Eelco}, 246 | Booktitle = {Generative and Transformational Techniques in Software Engineering II}, 247 | Publisher = {Springer}, 248 | Year = {2008}, 249 | Pages = {291--373}, 250 | Owner = {sf37}, 251 | Timestamp = {2013.07.31} 252 | } 253 | 254 | @Electronic{w3techs:webpls, 255 | Title = {Usage of server-side programming languages for websites}, 256 | Author = {{W3Techs}}, 257 | Month = {July}, 258 | Url = {http://w3techs.com/technologies/overview/programming_language/all}, 259 | Year = {2013}, 260 | 261 | Owner = {sf37}, 262 | Timestamp = {2013.07.30} 263 | } 264 | 265 | @incollection{cooper:formlets, 266 | title={The essence of form abstraction}, 267 | author={Cooper, Ezra and Lindley, Sam and Wadler, Philip and Yallop, Jeremy}, 268 | booktitle={Programming Languages and Systems}, 269 | pages={205--220}, 270 | year={2008}, 271 | publisher={Springer} 272 | } 273 | 274 | @article{mcbride:applicative, 275 | title={Functional Pearl: Applicative programming with effects}, 276 | author={McBride, Conor and Paterson, Ross}, 277 | journal={Journal of functional programming}, 278 | volume={18}, 279 | number={1}, 280 | pages={1--13}, 281 | year={2008}, 282 | publisher={Cambridge Univ Press} 283 | } 284 | 285 | @incollection{deline:typestates, 286 | title={Typestates for objects}, 287 | author={DeLine, Robert and F{\"a}hndrich, Manuel}, 288 | booktitle={ECOOP 2004--Object-Oriented Programming}, 289 | pages={465--490}, 290 | year={2004}, 291 | publisher={Springer} 292 | } 293 | 294 | @article{queinnec:ioc, 295 | title={Inverting back the inversion of control or, continuations versus page-centric programming}, 296 | author={Queinnec, Christian}, 297 | journal={ACM SIGPLAN Notices}, 298 | volume={38}, 299 | number={2}, 300 | pages={57--64}, 301 | year={2003}, 302 | publisher={ACM} 303 | } 304 | -------------------------------------------------------------------------------- /src/IdrisWeb/CGI/CgiTypes.idr: -------------------------------------------------------------------------------- 1 | module IdrisWeb.CGI.CgiTypes 2 | 3 | import Effects 4 | import Decidable.Equality 5 | import IdrisWeb.DB.SQLite.SQLiteNew 6 | import IdrisWeb.Session.Session 7 | %access public 8 | -- Types used by the CGI module 9 | 10 | -- Simple type synonym for a list of key value pairs 11 | public 12 | Vars : Type 13 | Vars = List (String, String) 14 | 15 | -- CGI Concrete effect sig 16 | public 17 | CGI : Type -> EFFECT 18 | 19 | FormHandler : List EFFECT -> Type 20 | FormHandler effs = Eff IO effs () 21 | 22 | public 23 | UserForm : Type 24 | 25 | -- Information passed by CGI 26 | public 27 | record CGIInfo : Type where 28 | CGIInf : (GET : Vars) -> 29 | (POST : Vars) -> 30 | (Cookies : Vars) -> 31 | (UserAgent : String) -> 32 | (Headers : String) -> 33 | (Output : String) -> 34 | (FormNumber : Nat) -> CGIInfo 35 | 36 | -- Type of user-defined 37 | public 38 | CGIProg : List EFFECT -> Type -> Type 39 | 40 | -- States in the state machine 41 | public 42 | data CGIStep = Initialised 43 | | TaskRunning 44 | | TaskCompleted 45 | | HeadersWritten 46 | | ContentWritten 47 | -- Perhaps another after any cleanup? 48 | 49 | 50 | 51 | -- Data type representing an initialised CGI script 52 | public 53 | data InitialisedCGI : CGIStep -> Type where 54 | ICgi : CGIInfo -> InitialisedCGI s 55 | 56 | {- Serialisable Web Effects -} 57 | 58 | data WebEffect = CgiEffect 59 | | SqliteEffect 60 | | SessionEffect 61 | 62 | cgiNotSqlite : CgiEffect = SqliteEffect -> _|_ 63 | cgiNotSqlite refl impossible 64 | 65 | cgiNotSession : CgiEffect = SessionEffect -> _|_ 66 | cgiNotSession refl impossible 67 | 68 | sqliteNotSession : SqliteEffect = SessionEffect -> _|_ 69 | sqliteNotSession refl impossible 70 | 71 | instance DecEq WebEffect where 72 | decEq CgiEffect CgiEffect = Yes refl 73 | decEq SqliteEffect SqliteEffect = Yes refl 74 | decEq CgiEffect SqliteEffect = No cgiNotSqlite 75 | decEq SqliteEffect CgiEffect = No (negEqSym cgiNotSqlite) 76 | decEq CgiEffect SessionEffect = No cgiNotSession 77 | decEq SessionEffect CgiEffect = No (negEqSym cgiNotSession) 78 | decEq SessionEffect SessionEffect = Yes refl 79 | decEq SqliteEffect SessionEffect = No sqliteNotSession 80 | decEq SessionEffect SqliteEffect = No (negEqSym sqliteNotSession) 81 | 82 | instance Eq WebEffect where 83 | (==) CgiEffect CgiEffect = True 84 | (==) SqliteEffect SqliteEffect = True 85 | (==) SessionEffect SessionEffect = True 86 | (==) _ _ = False 87 | 88 | instance Show WebEffect where 89 | show CgiEffect = "cgi" 90 | show SqliteEffect = "sqlite" 91 | show SessionEffect = "session" 92 | 93 | total 94 | interpWebEffect : WebEffect -> EFFECT 95 | interpWebEffect CgiEffect = (CGI (InitialisedCGI TaskRunning)) 96 | interpWebEffect SqliteEffect = (SQLITE ()) 97 | interpWebEffect SessionEffect = (SESSION (SessionRes SessionUninitialised)) 98 | 99 | interpWebEffects : List WebEffect -> List EFFECT 100 | interpWebEffects [] = [] 101 | interpWebEffects (x :: xs) = interpWebEffect x :: interpWebEffects xs 102 | 103 | 104 | 105 | {- Allowed form types -} 106 | 107 | data FormTy = FormString 108 | | FormInt 109 | | FormBool 110 | | FormFloat 111 | | FormList FormTy 112 | 113 | total 114 | interpFormTy : FormTy -> Type 115 | interpFormTy FormString = String 116 | interpFormTy FormInt = Int 117 | interpFormTy FormBool = Bool 118 | interpFormTy FormFloat = Float 119 | interpFormTy (FormList a) = List (interpFormTy a) 120 | 121 | instance Eq FormTy where 122 | (==) FormString FormString = True 123 | (==) FormInt FormInt = True 124 | (==) FormBool FormBool = True 125 | (==) FormFloat FormFloat = True 126 | (==) (FormList a) (FormList b) = (a == b) 127 | (==) _ _ = False 128 | 129 | instance Show FormTy where 130 | show FormString = "str" 131 | show FormInt = "int" 132 | show FormBool = "bool" 133 | show FormFloat = "float" 134 | show (FormList a) = "list_" ++ (show a) 135 | 136 | 137 | formstringNotFormInt : FormString = FormInt -> _|_ 138 | formstringNotFormInt refl impossible 139 | formstringNotFormBool : FormString = FormBool -> _|_ 140 | formstringNotFormBool refl impossible 141 | formstringNotFormFloat : FormString = FormFloat -> _|_ 142 | formstringNotFormFloat refl impossible 143 | formstringNotFormList : FormString = (FormList a) -> _|_ 144 | formstringNotFormList refl impossible 145 | formintNotFormBool : FormInt = FormBool -> _|_ 146 | formintNotFormBool refl impossible 147 | formintNotFormFloat : FormInt = FormFloat -> _|_ 148 | formintNotFormFloat refl impossible 149 | formintNotFormList : FormInt = (FormList a) -> _|_ 150 | formintNotFormList refl impossible 151 | formboolNotFormFloat : FormBool = FormFloat -> _|_ 152 | formboolNotFormFloat refl impossible 153 | formboolNotFormList : FormBool = (FormList a) -> _|_ 154 | formboolNotFormList refl impossible 155 | formfloatNotFormList : FormFloat = (FormList a) -> _|_ 156 | formfloatNotFormList refl impossible 157 | 158 | lemma_fl_injective : {a : FormTy} -> {b : FormTy} -> (FormList a = FormList b) -> a = b 159 | lemma_fl_injective refl = refl 160 | 161 | lemma_a_not_b : {a : FormTy} -> {b : FormTy} -> ((a = b) -> _|_) -> ((FormList a = FormList b) -> _|_) 162 | lemma_a_not_b p h = p (lemma_fl_injective h) 163 | 164 | instance DecEq FormTy where 165 | decEq FormString FormString = Yes refl 166 | decEq FormString FormInt = No formstringNotFormInt 167 | decEq FormString FormBool = No formstringNotFormBool 168 | decEq FormString FormFloat = No formstringNotFormFloat 169 | decEq FormString (FormList a) = No formstringNotFormList 170 | decEq FormInt FormString = No (negEqSym formstringNotFormInt) 171 | decEq FormInt FormInt = Yes refl 172 | decEq FormInt FormBool = No formintNotFormBool 173 | decEq FormInt FormFloat = No formintNotFormFloat 174 | decEq FormInt (FormList a) = No formintNotFormList 175 | decEq FormBool FormString = No (negEqSym formstringNotFormBool) 176 | decEq FormBool FormInt = No (negEqSym formintNotFormBool) 177 | decEq FormBool FormBool = Yes refl 178 | decEq FormBool FormFloat = No formboolNotFormFloat 179 | decEq FormBool (FormList a) = No formboolNotFormList 180 | decEq FormFloat FormString = No (negEqSym formstringNotFormFloat) 181 | decEq FormFloat FormInt = No (negEqSym formintNotFormFloat) 182 | decEq FormFloat FormBool = No (negEqSym formboolNotFormFloat) 183 | decEq FormFloat FormFloat = Yes refl 184 | decEq FormFloat (FormList a) = No formfloatNotFormList 185 | decEq (FormList a) FormString = No (negEqSym formstringNotFormList) 186 | decEq (FormList a) FormInt = No (negEqSym formintNotFormList) 187 | decEq (FormList a) FormBool = No (negEqSym formboolNotFormList) 188 | decEq (FormList a) FormFloat = No (negEqSym formfloatNotFormList) 189 | decEq (FormList a) (FormList b) with (decEq a b) 190 | decEq (FormList a) (FormList a) | Yes refl = Yes refl 191 | decEq (FormList a) (FormList b) | No p = No (lemma_a_not_b p) 192 | 193 | MkHandlerFnTy : Type 194 | MkHandlerFnTy = (List FormTy, List WebEffect) 195 | 196 | mkHandlerFn' : List FormTy -> List WebEffect -> Type 197 | mkHandlerFn' [] effs = FormHandler (interpWebEffects effs) 198 | mkHandlerFn' (x :: xs) effs = Maybe (interpFormTy x) -> mkHandlerFn' xs effs 199 | 200 | mkHandlerFn : MkHandlerFnTy -> Type 201 | mkHandlerFn (tys, effs) = mkHandlerFn' tys effs 202 | 203 | public 204 | HandlerFn : Type 205 | HandlerFn = (ft ** (mkHandlerFn ft, String)) 206 | 207 | public 208 | HandlerList : Type 209 | HandlerList = List HandlerFn 210 | 211 | 212 | using (G : List FormTy, E : List WebEffect) 213 | data FormRes : List FormTy -> List WebEffect -> Type where 214 | FR : Nat -> List FormTy -> List WebEffect -> String -> FormRes G E 215 | 216 | data FnElem : mkHandlerFn ((reverse G), E) -> HandlerList -> Type where 217 | FnHere : {xs : HandlerList, f : mkHandlerFn ((reverse G), E)} -> 218 | FnElem f ((((reverse G), E) ** (f, fStr)) :: xs) 219 | FnThere : {xs : HandlerList, f : mkHandlerFn ((reverse G), E)} -> 220 | FnElem f xs -> FnElem f (x :: xs) 221 | 222 | findFn : Nat -> List (TTName, Binder TT) -> TT -> Tactic -- Nat is maximum search depth 223 | findFn Z ctxt goal = Refine "FnHere" `Seq` Solve 224 | findFn (S n) ctxt goal = GoalType "FnElem" 225 | (Try (Refine "FnHere" `Seq` Solve) 226 | (Refine "FnThere" `Seq` (Solve `Seq` findFn n ctxt goal))) 227 | 228 | 229 | getString' : (f : mkHandlerFn ((reverse G), E)) -> 230 | (fs : HandlerList) -> FnElem f fs -> String 231 | getString' f ((_ ** (_, n)) :: _) FnHere = n 232 | getString' f (_ :: fs) (FnThere p) = getString' f fs p 233 | 234 | 235 | data Form : Effect where 236 | AddTextBox : (label : String) -> 237 | (fty : FormTy) -> 238 | (Maybe (interpFormTy fty)) -> 239 | Form (FormRes G E) (FormRes (fty :: G) E) () 240 | 241 | AddHidden : (fty : FormTy) -> 242 | (interpFormTy fty) -> 243 | Form (FormRes G E) (FormRes (fty :: G) E) () 244 | 245 | AddSelectionBox : (label : String) -> 246 | (fty : FormTy) -> 247 | (vals : Vect m (interpFormTy fty)) -> 248 | (names : Vect m String) -> 249 | Form (FormRes G E) (FormRes (fty :: G) E) () 250 | 251 | AddRadioGroup : (label : String) -> 252 | (fty : FormTy) -> 253 | (vals : Vect m (interpFormTy fty)) -> 254 | (names : Vect m String) -> 255 | (default : Int) -> 256 | Form (FormRes G E) (FormRes (fty :: G) E) () 257 | 258 | AddCheckBoxes : (label : String) -> 259 | (fty : FormTy) -> 260 | (vals : Vect m (interpFormTy fty)) -> 261 | (names : Vect m String) -> 262 | (checked_boxes : Vect m Bool) -> 263 | Form (FormRes G E) (FormRes ((FormList fty) :: G) E) () 264 | 265 | UseEffects : (effs : List WebEffect) -> 266 | Form (FormRes G E) (FormRes G effs) () 267 | 268 | Submit : (mkHandlerFn ((reverse G), E)) -> 269 | String -> 270 | Form (FormRes G E) (FormRes [] []) String 271 | 272 | FORM : Type -> EFFECT 273 | FORM t = MkEff t Form 274 | 275 | addTextBox : String -> 276 | (fty : FormTy) -> -- Data type 277 | (Maybe (interpFormTy fty)) -> -- Default data value (optional) 278 | EffM m [FORM (FormRes G E)] [FORM (FormRes (fty :: G) E)] () 279 | addTextBox label ty val = (AddTextBox label ty val) 280 | 281 | addHidden : (fty : FormTy) -> 282 | (interpFormTy fty) -> -- Default value 283 | EffM m [FORM (FormRes G E)] [FORM (FormRes (fty :: G) E)] () 284 | addHidden ty val = (AddHidden ty val) 285 | 286 | addSelectionBox : String -> 287 | (fty : FormTy) -> 288 | (vals : Vect j (interpFormTy fty)) -> 289 | (names : Vect j String) -> 290 | EffM m [FORM (FormRes G E)] [FORM (FormRes (fty :: G) E)] () 291 | addSelectionBox label ty vals names = (AddSelectionBox label ty vals names) 292 | 293 | addRadioGroup : String -> 294 | (fty : FormTy) -> 295 | (vals : Vect j (interpFormTy fty)) -> 296 | (names : Vect j String) -> 297 | (default : Int) -> 298 | EffM m [FORM (FormRes G E)] [FORM (FormRes (fty :: G) E)] () 299 | addRadioGroup label ty vals names default = (AddRadioGroup label ty vals names default) 300 | 301 | addCheckBoxes : (label : String) -> 302 | (fty : FormTy) -> 303 | (vals : Vect j (interpFormTy fty)) -> 304 | (names : Vect j String) -> 305 | (checked_boxes : Vect j Bool) -> 306 | EffM m [FORM (FormRes G E)] [FORM (FormRes ((FormList fty) :: G) E)] () 307 | addCheckBoxes label ty vals names checked = (AddCheckBoxes label ty vals names checked) 308 | 309 | addSubmit : (f : mkHandlerFn ((reverse G), E)) -> 310 | (fns : HandlerList) -> 311 | {default tactics { applyTactic findFn 100; solve; } 312 | prf : FnElem f fns} -> 313 | EffM m [FORM (FormRes G E)] [FORM (FormRes [] [])] String 314 | addSubmit f handlers {prf} = (Submit f name) 315 | where name : String 316 | name = getString' f handlers prf 317 | 318 | useEffects : (effs : List WebEffect) -> 319 | EffM m [FORM (FormRes G E)] [FORM (FormRes G effs)] () 320 | useEffects effs = (UseEffects effs) 321 | 322 | UserForm = Eff id [FORM (FormRes [] [])] String -- Making a form is a pure function (atm) 323 | 324 | 325 | 326 | -- CGI Effect 327 | public 328 | data Cgi : Effect where 329 | -- Individual functions of the effect 330 | 331 | -- Action retrieval 332 | GetInfo : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) CGIInfo 333 | 334 | -- Output a string 335 | OutputData : String -> Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) () 336 | 337 | -- Retrieve the GET variables 338 | GETVars : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) Vars 339 | 340 | -- Retrieve the POST variables 341 | POSTVars : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) Vars 342 | 343 | -- Retrieve the cookie variables 344 | CookieVars : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) Vars 345 | 346 | -- Lookup a variable in the GET variables 347 | QueryGetVar : String -> Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) (Maybe String) 348 | 349 | -- Lookup a variable in the POST variables 350 | QueryPostVar : String -> Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) (Maybe String) 351 | 352 | -- Lookup a cookie from the cookie variables 353 | QueryCookieVar : String -> Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) (Maybe String) 354 | 355 | -- Retrieves the current output 356 | GetOutput : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) String 357 | 358 | -- Retrieves the headers 359 | GetHeaders : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) String 360 | 361 | -- Flushes the headers to StdOut 362 | FlushHeaders : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) () 363 | 364 | -- Flushes output to StdOut 365 | Flush : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) () 366 | 367 | -- Initialise the internal CGI State 368 | Init : Cgi () (InitialisedCGI Initialised) () 369 | 370 | -- Transition to task started state 371 | StartRun : Cgi (InitialisedCGI Initialised) (InitialisedCGI TaskRunning) () 372 | 373 | -- Transition to task completed state 374 | FinishRun : Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskCompleted) () 375 | 376 | -- Write headers, transition to headers written state 377 | WriteHeaders : Cgi (InitialisedCGI TaskCompleted) (InitialisedCGI HeadersWritten) () 378 | 379 | -- Write content, transition to content written state 380 | WriteContent : Cgi (InitialisedCGI HeadersWritten) (InitialisedCGI ContentWritten) () 381 | 382 | -- Add cookie 383 | -- TODO: Add expiry date in here once I've finished the basics 384 | SetCookie : String -> String -> {- Date -> -} 385 | Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) () 386 | 387 | -- Run the user-specified action 388 | RunAction : Env IO (CGI (InitialisedCGI TaskRunning) :: effs) -> 389 | CGIProg effs a -> 390 | Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) a 391 | 392 | -- Write a form to the web page 393 | AddForm : UserForm -> 394 | Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) () 395 | 396 | -- Attempts to handle a form, given a list of available handlers 397 | HandleForm : HandlerList -> 398 | Cgi (InitialisedCGI TaskRunning) (InitialisedCGI TaskRunning) Bool 399 | 400 | 401 | CGI t = MkEff t Cgi 402 | 403 | CGIProg effs a = Eff IO (CGI (InitialisedCGI TaskRunning) :: effs) a 404 | 405 | interpFnTy : Vect n FormTy -> Type 406 | interpFnTy tys = interpFnTy' (reverse tys) 407 | where interpFnTy' : Vect n FormTy -> Type 408 | interpFnTy' [] = () -- TODO: should be form effect stuff here 409 | interpFnTy' (x :: xs) = interpFormTy x -> interpFnTy' xs 410 | 411 | 412 | 413 | SerialisedForm : Type 414 | SerialisedForm = String 415 | 416 | 417 | 418 | data PopFn : Type where 419 | PF : (w_effs : List WebEffect) -> 420 | (effs : List EFFECT) -> (env : Effects.Env IO effs) -> 421 | Eff IO effs () -> PopFn 422 | 423 | 424 | {- 425 | test1 : Maybe String -> Maybe Int -> FormHandler [CGI (InitialisedCGI TaskRunning)] 426 | test1 (Just name) (Just age) = do 427 | --output $ "Your name is " ++ name 428 | --output $ " and you are " ++ (show age) ++ " years old!" 429 | pure () 430 | 431 | 432 | test2 : Maybe String -> Maybe String -> FormHandler [CGI (InitialisedCGI TaskRunning), SQLITE ()] 433 | test2 (Just name) (Just name2) = do 434 | --output $ "Your name is " ++ name 435 | --output $ " and your last name is " ++ name2 436 | pure () 437 | -} 438 | {- 439 | fnList : HandlerList 440 | fnList = [(([FormString, FormInt], [CgiEffect]) ** (test1, "test1")), 441 | (([FormString, FormString], [CgiEffect, SqliteEffect]) ** (test2, "test2"))] 442 | -} 443 | 444 | ----- 445 | ----- END NEW STUFF 446 | ----- 447 | 448 | -------------------------------------------------------------------------------- /src/IdrisWeb/CGI/CgiUtils.idr: -------------------------------------------------------------------------------- 1 | module IdrisWeb.Effect.Cgi 2 | 3 | -- Pure functions used by the CGI effects library 4 | -- SimonJF 5 | 6 | import System 7 | 8 | 9 | -- Pure, non-effecting functions 10 | abstract 11 | getVars : List Char -> String -> List (String, String) 12 | getVars seps query = mapMaybe readVar (split (\x => elem x seps) query) 13 | where 14 | readVar : String -> Maybe (String, String) 15 | readVar xs with (split (\x => x == '=') xs) 16 | | [k, v] = Just (trim k, trim v) 17 | | _ = Nothing 18 | 19 | -- Returns either the environment variable, or the empty string if it does not exist 20 | abstract 21 | safeGetEnvVar : String -> IO String 22 | safeGetEnvVar varname = do env_var <- getEnv varname 23 | case env_var of 24 | Just var => pure var 25 | Nothing => pure "" 26 | 27 | 28 | private 29 | getContent' : Int -> IO String --Eff IO [EXTENDEDSTDIO] String 30 | getContent' x = getC x "" where 31 | %assert_total 32 | getC : Int -> String -> IO String 33 | getC 0 acc = pure $ reverse acc 34 | getC n acc = if (n > 0) 35 | then do x <- getChar 36 | getC (n-1) (strCons x acc) 37 | else (pure "") 38 | 39 | 40 | 41 | -- Gets the content of the user data. 42 | -- If CONTENT_LENGTH is not present, returns the empty string. 43 | abstract 44 | getContent : IO String 45 | getContent = do 46 | clen_in <- getEnv "CONTENT_LENGTH" -- Check for CONTENT_LENGTH existence 47 | case clen_in of 48 | Just content_length => do let clen = prim__fromStrInt content_length 49 | getContent' clen -- Get content from content length 50 | Nothing => pure "" 51 | 52 | 53 | 54 | -------------------------------------------------------------------------------- /src/IdrisWeb/CGI/formhello.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | import Cgi 3 | import Effects 4 | 5 | sayHello : Maybe String -> FormHandler [CGI (InitialisedCGI TaskRunning)] 6 | sayHello (Just name) = output ("Hello, " ++ name ++ "!") 7 | 8 | handlers : HandlerList 9 | handlers = [(handler args=[FormString], effects=[CgiEffect], fn=sayHello, name="sayHello")] 10 | 11 | showHelloForm : UserForm 12 | showHelloForm = do 13 | addTextBox "Name" FormString Nothing 14 | useEffects [CgiEffect] 15 | addSubmit sayHello handlers 16 | 17 | cgiHello : CGIProg [] () 18 | cgiHello = do 19 | handler_set <- isHandlerSet 20 | if handler_set then do 21 | handleForm handlers 22 | return () 23 | else do 24 | addForm "nameform" "helloform" showHelloForm 25 | return () 26 | 27 | main : IO () 28 | main = runCGI [initCGIState] cgiHello 29 | -------------------------------------------------------------------------------- /src/IdrisWeb/CGI/helloworld.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | import Cgi 3 | 4 | sayHello : CGIProg [] () 5 | sayHello = output "Hello, world!" 6 | 7 | main : IO () 8 | main = runCGI [initCGIState] sayHello 9 | -------------------------------------------------------------------------------- /src/IdrisWeb/CGI/test.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | import Cgi 3 | import Effects 4 | import Session 5 | import SessionUtils 6 | 7 | 8 | 9 | incrementAndGetCount : SessionData -> Eff IO [SESSION (SessionRes SessionInitialised)] Int 10 | incrementAndGetCount sd = case lookup "counter" sd of 11 | Just (SInt c) => do updateSession $ updateVar "counter" (SInt (c + 1)) sd 12 | return (c + 1) 13 | _ => do updateSession $ updateVar "counter" (SInt 1) sd -- Start a new counter 14 | return 1 15 | 16 | 17 | -- TODO: Update CGIProg to the EffM definition instead of the Eff definition 18 | useSession : Maybe (SessionID, SessionData) -> EffM IO [CGI (InitialisedCGI TaskRunning), SESSION (SessionRes SessionInitialised)] 19 | [CGI (InitialisedCGI TaskRunning), SESSION (SessionRes SessionUninitialised)] 20 | () 21 | useSession (Just (si, sd)) = do count <- lift' (incrementAndGetCount sd) 22 | lift' (output $ "You have visited this page " ++ (show count) ++ " time(s)!") 23 | lift' writeSessionToDB 24 | Effects.pure () 25 | useSession Nothing = do output "There was a problem retrieving your session." 26 | -- Delete the session for good measure 27 | -- whoops, haven't written this yet 28 | discardSession 29 | Effects.pure () 30 | 31 | 32 | doCGIStuff : Eff IO [CGI (InitialisedCGI TaskRunning), SESSION (SessionRes SessionUninitialised)] () 33 | doCGIStuff = do lift' (output "Hello, world!\n") 34 | session <- getOrCreateSession 35 | useSession session 36 | 37 | main : IO () 38 | main = do 39 | runCGI [initCGIState, InvalidSession] doCGIStuff 40 | pure () 41 | 42 | 43 | -------------------------------------------------------------------------------- /src/IdrisWeb/Common/Date.idr: -------------------------------------------------------------------------------- 1 | module IdrisWeb.Common.Date 2 | import Builtins 3 | %access public 4 | 5 | {- Simple date and time records. 6 | Like, really simple. They'll do for now. 7 | 8 | Allows date serialisation and deserialisation as per 9 | RFC822, which is used when setting cookies. 10 | 11 | TODO: Timezones, timestamp, comparison 12 | 13 | -} 14 | 15 | data Day = Monday 16 | | Tuesday 17 | | Wednesday 18 | | Thursday 19 | | Friday 20 | | Saturday 21 | | Sunday 22 | 23 | 24 | data Month = January 25 | | February 26 | | March 27 | | April 28 | | May 29 | | June 30 | | July 31 | | August 32 | | September 33 | | October 34 | | November 35 | | December 36 | 37 | -- Not using the show typeclass for cookies, since there are so many 38 | -- different ways of showing dates. 39 | showCookieDay : Day -> String 40 | showCookieDay Monday = "Mon" 41 | showCookieDay Tuesday = "Tue" 42 | showCookieDay Wednesday = "Wed" 43 | showCookieDay Thursday = "Thu" 44 | showCookieDay Friday = "Fri" 45 | showCookieDay Saturday = "Sat" 46 | showCookieDay Sunday = "Sun" 47 | 48 | 49 | --private 50 | {- 51 | divides : Integer -> Integer -> Bool 52 | divides x y = (x `mod` y) == 0 53 | 54 | isLeapYear : (year : Integer) -> Bool 55 | isLeapYear y = if divides y 400 then True 56 | else if divides y 100 then False 57 | else if divides y 4 then True 58 | else False 59 | 60 | 61 | -- where y : Nat 62 | -- y = cast year 63 | -} 64 | 65 | isLeapYear : (year : Integer) -> Bool 66 | isLeapYear year = if (y `mod` 400) == O then True 67 | else if (y `mod` 100) == O then False 68 | else if (y `mod` 4) == O then True 69 | else False 70 | where y : Nat 71 | y = cast year 72 | 73 | daysInMonth : Month -> (year : Integer) -> Int 74 | daysInMonth September _ = 30 75 | daysInMonth April _ = 30 76 | daysInMonth June _ = 30 77 | daysInMonth November _ = 30 78 | daysInMonth February y = if isLeapYear y then 29 79 | else 28 80 | daysInMonth _ _ = 31 81 | 82 | dayOfWeek : (year : Integer) -> (month : Integer) -> (day : Integer) -> Int 83 | dayOfWeek year month day = d + (2.6 * m) 84 | where y = if (month == 1 || month == 2) then year - 1 else year 85 | m = (month - 2) `mod` 12 86 | d = daysInMonth month 87 | 88 | public 89 | record Date : Type where 90 | MkDate : (day : Integer) -> 91 | (month : Integer) -> 92 | (year : Integer) -> Date 93 | 94 | public 95 | record DateTime : Type where 96 | MkDateTime : (day : Integer) -> 97 | (month : Integer) -> 98 | (year : Integer) -> 99 | (hour : Integer) -> 100 | (minute : Integer) -> 101 | (second : Integer) -> 102 | DateTime 103 | 104 | 105 | -- Why everyone can't just use the ISO one, I'll never know... 106 | -- Wed, 13 Jan 2021 22:23:01 GMT 107 | --abstract 108 | --showCookieTime : DateTime -> String 109 | --showCookieTime dt 110 | -------------------------------------------------------------------------------- /src/IdrisWeb/Common/Parser.idr: -------------------------------------------------------------------------------- 1 | {- 2 | Simple monadic parser module, based heavily on that by 3 | Graham Hutton. 4 | -} 5 | 6 | module IdrisWeb.Common.Parser 7 | 8 | import Prelude 9 | import Prelude.Monad 10 | import Prelude.Applicative 11 | import Prelude.List 12 | import Builtins 13 | 14 | %access public 15 | 16 | infixr 5 ||| 17 | 18 | {- 19 | The monad of parsers 20 | -------------------- 21 | -} 22 | 23 | data Parser a = P (String -> Either String (a, String)) 24 | 25 | parse : Parser a -> String -> Either String (a, String) 26 | parse (P p) inp = p inp 27 | 28 | instance Functor Parser where 29 | -- fmap : (a -> b) -> f a -> f b 30 | -- fmap : (a -> b) -> Parser a -> Parser b 31 | -- Given a function (a -> b), and a parser a, make a parser b 32 | map f p = P (\inp => case parse p inp of 33 | (Left err) => Left err 34 | -- Apply f to the v that we got from parsing 35 | (Right (v, rest)) => Right ((f v), rest)) 36 | 37 | 38 | instance Applicative Parser where 39 | pure v = P (\inp => Right (v, inp)) 40 | -- Parse to get the function, then parse to get the first argument 41 | a <$> b = P (\inp => do (f, rest) <- parse a inp 42 | (x, rest') <- parse b rest 43 | pure ((f x), rest')) 44 | 45 | instance Monad Parser where 46 | -- pure v = P (\inp => Right (v,inp)) 47 | -- m a -> (a -> m b) -> m b 48 | p >>= f = P (\inp => case parse p inp of 49 | (Left err) => Left err 50 | (Right (v,rest)) => parse (f v) rest) 51 | 52 | --mplus : Monad m => m a -> m a -> m a 53 | mplus : Parser a -> Parser a -> Parser a 54 | mplus p q = P (\inp => case parse p inp of 55 | Left msg => parse q inp 56 | Right (v,out) => Right(v,out)) 57 | 58 | 59 | {- 60 | Basic parsers 61 | ------------- 62 | -} 63 | 64 | failure : String -> Parser a 65 | failure msg = P (\inp => Left msg) 66 | 67 | item : Parser Char 68 | item = P (\inp => case unpack inp of 69 | [] => Left "Error! Parsing empty list." 70 | (x::xs) => Right (x, pack xs)) 71 | 72 | 73 | {- 74 | Choice 75 | -------- 76 | ---} 77 | 78 | (|||) : Parser a -> Parser a -> Parser a 79 | p ||| q = p `mplus` q 80 | 81 | 82 | --{- 83 | --Derived primitives 84 | ---} 85 | 86 | sat : (Char -> Bool) -> Parser Char 87 | sat p = item >>= (\x => if p x then pure x else failure "failed") 88 | 89 | oneof : List Char -> Parser Char 90 | oneof xs = sat (\x => elem x xs) 91 | 92 | digit : Parser Char 93 | digit = sat isDigit 94 | 95 | lower : Parser Char 96 | lower = sat isLower 97 | 98 | upper : Parser Char 99 | upper = sat isUpper 100 | 101 | letter : Parser Char 102 | letter = sat isAlpha 103 | 104 | alphanum : Parser Char 105 | alphanum = sat isAlphaNum 106 | 107 | char : Char -> Parser Char 108 | char x = sat (== x) 109 | 110 | helper : List Char -> Parser (List Char) 111 | string : String -> Parser String 112 | string s = do result <- helper (unpack s) 113 | pure (pack result) 114 | 115 | helper [] = pure Prelude.List.Nil 116 | helper (x::xs) = do char x 117 | string (cast xs) 118 | pure (x :: xs) 119 | 120 | many : Parser a -> Parser (List a) 121 | many1 : Parser a -> Parser (List a) 122 | many1 p = do v <- p 123 | vs <- many p 124 | pure $ Prelude.List.(::) v vs 125 | 126 | 127 | bool : Parser Bool 128 | bool = parseTrue ||| parseFalse 129 | where parseTrue : Parser Bool 130 | parseTrue = do oneof ['T', 't'] 131 | string "rue" 132 | pure True 133 | parseFalse = do oneof ['F', 'f'] 134 | string "alse" 135 | pure False 136 | 137 | 138 | 139 | 140 | many p = many1 p `mplus` pure Prelude.List.Nil 141 | 142 | 143 | 144 | ident : Parser String 145 | ident = do x <- letter 146 | xs <- many1 alphanum 147 | pure (pack(x::xs)) 148 | 149 | nat : Parser Int 150 | nat = do xs <- many1 digit 151 | pure (cast (cast xs)) 152 | 153 | 154 | int : Parser Int 155 | int = neg ||| nat 156 | where neg : Parser Int 157 | neg = do char '-' 158 | n <- nat 159 | pure (-n) 160 | 161 | space : Parser () 162 | space = do many (sat isSpace) 163 | pure () 164 | --{- 165 | --Ignoring spacing 166 | ---} 167 | 168 | token : Parser a -> Parser a 169 | token p = do space 170 | v <- p 171 | space 172 | pure v 173 | 174 | identifier : Parser String 175 | identifier = token ident 176 | 177 | natural : Parser Int 178 | natural = token nat 179 | 180 | integer : Parser Int 181 | integer = token int 182 | 183 | symbol : String -> Parser String 184 | symbol xs = token (string xs) 185 | 186 | strToken : Parser String 187 | strToken = map pack (token (many1 alphanum)) 188 | 189 | --apply : Parser a -> String -> List (a,String) 190 | --apply p = parse (space >>= (\_ => p)) 191 | 192 | --{- 193 | -- Expressions 194 | ---} 195 | 196 | factor : Parser Int 197 | term : Parser Int 198 | expr : Parser Int 199 | expr = do t <- term 200 | do symbol "+" 201 | e <- expr 202 | pure $ t + e 203 | `mplus` pure t 204 | 205 | 206 | factor = do symbol "(" 207 | do e <- expr 208 | symbol ")" 209 | pure e 210 | `mplus` natural 211 | 212 | term = do f <- factor 213 | do symbol "*" 214 | t <- term 215 | pure (f * t) 216 | `mplus` pure f 217 | 218 | 219 | 220 | eval : String -> Maybe Int 221 | eval xs = case (parse expr xs) of 222 | Right (n,rest) => if rest == "" then Just n else Nothing 223 | Left msg => Nothing 224 | -------------------------------------------------------------------------------- /src/IdrisWeb/Common/Random/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY : all 2 | 3 | rand_c.o : rand_c.c rand_c.h 4 | gcc -c rand_c.c 5 | 6 | rand_c.so : rand_c.c 7 | gcc - fPIC -o rand_c.so -shared rand_c.c 8 | 9 | all : rand_c.o rand_c.so 10 | -------------------------------------------------------------------------------- /src/IdrisWeb/Common/Random/RandC.idr: -------------------------------------------------------------------------------- 1 | module IdrisWeb.Common.Random.RandC 2 | -- Simple binding to a simple C random number library 3 | 4 | %link C "rand_c.o" 5 | %include C "rand_c.h" 6 | 7 | getRandom : Int -> Int -> IO Int 8 | getRandom min max = mkForeign (FFun "random_number" [FInt, FInt] FInt) min max 9 | 10 | 11 | {- 12 | -- Quick test harness 13 | main : IO () 14 | main = do 15 | rand1 <- getRandom 100 1005 16 | rand2 <- getRandom 1200000 1230423 17 | putStrLn $ "random 1: " ++ (show rand1) ++ ", random 2: " ++ (show rand2) 18 | -} 19 | 20 | 21 | -------------------------------------------------------------------------------- /src/IdrisWeb/DB/SQLite/SQLiteCodes.idr: -------------------------------------------------------------------------------- 1 | module IdrisWeb.DB.SQLite.SQLiteCodes 2 | -- Status codes for SQLite 3 | 4 | %access public 5 | 6 | SQLiteCode : Type 7 | SQLiteCode = Int 8 | 9 | sqlite_OK : Int 10 | sqlite_OK = 0 -- Successful result 11 | -- beginning-of-error-codes 12 | 13 | sqlite_ERROR : Int 14 | sqlite_ERROR = 1 -- SQL error or missing database 15 | 16 | sqlite_INTERNAL : Int 17 | sqlite_INTERNAL = 2 -- Internal logic error in SQLite 18 | 19 | sqlite_PERM : Int 20 | sqlite_PERM = 3 -- Access permission denied 21 | 22 | sqlite_ABORT : Int 23 | sqlite_ABORT = 4 -- Callback routine requested an abort 24 | 25 | sqlite_BUSY : Int 26 | sqlite_BUSY = 5 -- The database file is locked 27 | 28 | sqlite_LOCKED : Int 29 | sqlite_LOCKED = 6 -- A table in the database is locked 30 | 31 | sqlite_NOMEM : Int 32 | sqlite_NOMEM = 7 -- A malloc() failed 33 | 34 | sqlite_READONLY : Int 35 | sqlite_READONLY = 8 -- Attempt to write a readonly database 36 | 37 | sqlite_INTERRUPT : Int 38 | sqlite_INTERRUPT = 9 -- Operation terminated by sqlite3_interrupt() 39 | 40 | sqlite_IOERR : Int 41 | sqlite_IOERR = 10 -- Some kind of disk I/O error occurred 42 | 43 | sqlite_CORRUPT : Int 44 | sqlite_CORRUPT = 11 -- The database disk image is malformed 45 | 46 | sqlite_NOTFOUND : Int 47 | sqlite_NOTFOUND = 12 -- Unknown opcode in sqlite3_file_control() 48 | 49 | sqlite_FULL : Int 50 | sqlite_FULL = 13 -- Insertion failed because database is full 51 | 52 | sqlite_CANTOPEN : Int 53 | sqlite_CANTOPEN = 14 -- Unable to open the database file 54 | 55 | sqlite_PROTOCOL : Int 56 | sqlite_PROTOCOL = 15 -- Database lock protocol error 57 | 58 | sqlite_EMPTY : Int 59 | sqlite_EMPTY = 16 -- Database is empty 60 | 61 | sqlite_SCHEMA : Int 62 | sqlite_SCHEMA = 17 -- The database schema changed 63 | 64 | sqlite_TOOBIG : Int 65 | sqlite_TOOBIG = 18 -- String or BLOB exceeds size limit 66 | 67 | sqlite_CONSTRAINT : Int 68 | sqlite_CONSTRAINT = 19 -- Abort due to constraint violation 69 | 70 | sqlite_MISMATCH : Int 71 | sqlite_MISMATCH = 20 -- Data type mismatch 72 | 73 | sqlite_MISUSE : Int 74 | sqlite_MISUSE = 21 -- Library used incorrectly 75 | 76 | sqlite_NOLFS : Int 77 | sqlite_NOLFS = 22 -- Uses OS features not supported on host 78 | 79 | sqlite_AUTH : Int 80 | sqlite_AUTH = 23 -- Authorization denied 81 | 82 | sqlite_FORMAT : Int 83 | sqlite_FORMAT = 24 -- Auxiliary database format error 84 | 85 | sqlite_RANGE : Int 86 | sqlite_RANGE = 25 -- 2nd parameter to sqlite3_bind out of range 87 | 88 | sqlite_NOTADB : Int 89 | sqlite_NOTADB = 26 -- File opened that is not a database file 90 | 91 | sqlite_NOTICE : Int 92 | sqlite_NOTICE = 27 -- Notifications from sqlite3_log() 93 | 94 | sqlite_WARNING : Int 95 | sqlite_WARNING = 28 -- Warnings from sqlite3_log() 96 | 97 | sqlite_ROW : Int 98 | sqlite_ROW = 100 -- sqlite3_step() has another row ready 99 | 100 | sqlite_DONE : Int 101 | sqlite_DONE = 101 -- sqlite3_step() has finished executing 102 | -- end-of-error-codes 103 | 104 | data StepResult = Unstarted 105 | | StepFail 106 | | StepComplete 107 | | NoMoreRows 108 | 109 | 110 | -- FIXME: For some reason, pattern matching doesn't work 111 | -- when using the 112 | stepResult : Int -> StepResult 113 | stepResult 100 = StepComplete -- step complete, but more data available 114 | stepResult 101 = NoMoreRows -- statement has been fully executed 115 | stepResult _ = StepFail -- an error occurred 116 | 117 | -------------------------------------------------------------------------------- /src/IdrisWeb/DB/SQLite/SQLiteNew.idr: -------------------------------------------------------------------------------- 1 | module IdrisWeb.DB.SQLite.SQLiteNew 2 | import Effects 3 | import IdrisWeb.DB.SQLite.SQLiteCodes 4 | 5 | %link C "sqlite3api.o" 6 | %include C "sqlite3api.h" 7 | %lib C "sqlite3" 8 | %access public 9 | 10 | data ConnectionPtr = ConnPtr Ptr 11 | data StmtPtr = PSPtr Ptr 12 | 13 | data DBVal = DBInt Int 14 | | DBText String 15 | | DBFloat Float 16 | | DBNull 17 | 18 | -- Type synonym for a table 19 | ResultSet : Type 20 | ResultSet = List (List DBVal) 21 | 22 | DBName : Type 23 | DBName = String 24 | 25 | QueryString : Type 26 | QueryString = String 27 | 28 | Column : Type 29 | Column = Int 30 | 31 | ArgPos : Type 32 | ArgPos = Int 33 | data BindError = BE ArgPos SQLiteCode 34 | 35 | {- Connection-stage resources -} 36 | data SQLiteConnected : Type where 37 | SQLConnection : ConnectionPtr -> SQLiteConnected 38 | 39 | {- PreparedStatement resources -} 40 | data BindStep = Binding | Bound 41 | 42 | data SQLitePSSuccess : BindStep -> Type where 43 | -- We record potential bind failures within the resource, 44 | -- and branch on the finishBind step. This prevents us from 45 | -- having to branch on every bind, which would be impractical. 46 | SQLitePS : ConnectionPtr -> StmtPtr -> SQLitePSSuccess a 47 | SQLiteBindFail : ConnectionPtr -> StmtPtr -> BindError -> SQLitePSSuccess a 48 | 49 | 50 | data SQLitePSFail : Type where 51 | PSFail : ConnectionPtr -> SQLitePSFail 52 | 53 | data SQLiteFinishBindFail : Type where 54 | SQLiteFBFail : ConnectionPtr -> StmtPtr -> SQLiteFinishBindFail 55 | 56 | {- Executing Resources -} 57 | -- Tag used to indicate whether another row may be fetched 58 | data ExecutionResult = ValidRow 59 | | InvalidRow 60 | 61 | data SQLiteExecuting : ExecutionResult -> Type where 62 | SQLiteE : ConnectionPtr -> StmtPtr -> SQLiteExecuting a 63 | 64 | data QueryError = ConnectionError SQLiteCode 65 | | BindingError BindError 66 | | StatementError SQLiteCode 67 | | ExecError String 68 | | InternalError 69 | 70 | instance Show QueryError where 71 | show (ConnectionError code) = "Error connecting to database, code: " ++ (show code) 72 | show (BindingError (BE ap code)) = "Error binding variable, pos: " ++ (show ap) ++ ", code: " ++ (show code) 73 | show (StatementError code) = "Error creating prepared statement, code: " ++ (show code) 74 | show (ExecError err) = err 75 | show (InternalError) = "Internal Error." 76 | data Sqlite : Effect where 77 | -- Opens a connection to the database 78 | OpenDB : DBName -> Sqlite () (Either () SQLiteConnected) (Either QueryError ()) 79 | -- Closes the database handle 80 | CloseDB : Sqlite (SQLiteConnected) () () 81 | -- Prepares a statement, given a basic query string 82 | PrepareStatement : QueryString -> Sqlite (SQLiteConnected) (Either (SQLitePSFail) (SQLitePSSuccess Binding)) 83 | (Either QueryError ()) 84 | -- Binds arguments to the given argument position 85 | BindInt : ArgPos -> Int -> Sqlite (SQLitePSSuccess Binding) (SQLitePSSuccess Binding) () 86 | BindFloat : ArgPos -> Float -> Sqlite (SQLitePSSuccess Binding) (SQLitePSSuccess Binding) () 87 | BindText : ArgPos -> String -> Int -> Sqlite (SQLitePSSuccess Binding) (SQLitePSSuccess Binding) () 88 | BindNull : ArgPos -> Sqlite (SQLitePSSuccess Binding) (SQLitePSSuccess Binding) () 89 | 90 | -- Checks to see whether all the binds were successful, if not then fails with the bind error 91 | FinishBind : Sqlite (SQLitePSSuccess Binding) (Either SQLiteFinishBindFail (SQLitePSSuccess Bound)) 92 | (Maybe QueryError) 93 | 94 | -- Executes the statement, and fetches the first row 95 | ExecuteStatement : Sqlite (SQLitePSSuccess Bound) (Either (SQLiteExecuting InvalidRow) 96 | (SQLiteExecuting ValidRow)) StepResult 97 | 98 | RowStep : Sqlite (SQLiteExecuting ValidRow) (Either (SQLiteExecuting InvalidRow) 99 | (SQLiteExecuting ValidRow)) StepResult 100 | 101 | -- We need two separate effects, but this is entirely non-user-facing due to 102 | -- if_valid in the wrapper function 103 | ResetFromEnd : Sqlite (SQLiteExecuting InvalidRow) 104 | (Either (SQLiteExecuting InvalidRow) 105 | (SQLiteExecuting ValidRow)) StepResult 106 | 107 | Reset : Sqlite (SQLiteExecuting ValidRow) (Either (SQLiteExecuting InvalidRow) 108 | (SQLiteExecuting ValidRow)) StepResult 109 | 110 | -- Column access functions 111 | GetColumnName : Column -> Sqlite (SQLiteExecuting ValidRow) (SQLiteExecuting ValidRow) String 112 | GetColumnDataSize : Column -> Sqlite (SQLiteExecuting ValidRow) (SQLiteExecuting ValidRow) Int 113 | GetColumnText : Column -> Sqlite (SQLiteExecuting ValidRow) (SQLiteExecuting ValidRow) String 114 | GetColumnInt : Column -> Sqlite (SQLiteExecuting ValidRow) (SQLiteExecuting ValidRow) Int 115 | 116 | -- Finalisation Functions 117 | FinaliseValid : Sqlite (SQLiteExecuting ValidRow) (SQLiteConnected) () 118 | FinaliseInvalid : Sqlite (SQLiteExecuting InvalidRow) (SQLiteConnected) () 119 | 120 | -- Cleanup functions to handle error states 121 | CleanupPSFail : Sqlite (SQLitePSFail) () () 122 | CleanupBindFail : Sqlite (SQLiteFinishBindFail) () () 123 | 124 | private 125 | foreignGetError : ConnectionPtr -> IO Int 126 | foreignGetError (ConnPtr ptr) = mkForeign (FFun "idr_errcode" [FPtr] FInt) ptr 127 | 128 | private 129 | foreignNextRow : ConnectionPtr -> IO StepResult 130 | foreignNextRow (ConnPtr ptr) = 131 | map stepResult (mkForeign (FFun "sqlite3_step_idr" [FPtr] FInt) ptr) 132 | 133 | private 134 | foreignFinalise : ConnectionPtr -> IO () 135 | foreignFinalise (ConnPtr c) = do mkForeign (FFun "sqlite3_finalize_idr" [FPtr] FInt) c 136 | return () 137 | 138 | private 139 | foreignClose : ConnectionPtr -> IO () 140 | foreignClose (ConnPtr c) = do mkForeign (FFun "sqlite3_close_idr" [FPtr] FInt) c 141 | return () 142 | -- That's the painful bit done, since exception branching will allow us to not have to do 143 | -- the ugliness of pass-through handlers 144 | instance Handler Sqlite IO where 145 | handle () (OpenDB file) k = do 146 | ff <- mkForeign (FFun "sqlite3_open_idr" [FString] FPtr) file 147 | is_null <- nullPtr ff 148 | if (not is_null) then k (Right (SQLConnection (ConnPtr ff))) (Right ()) 149 | else k (Left ()) (Left (ConnectionError sqlite_ERROR)) 150 | 151 | handle (SQLConnection (ConnPtr conn) ) CloseDB k = do 152 | mkForeign (FFun "sqlite3_close_idr" [FPtr] FInt) conn 153 | k () () 154 | 155 | handle (SQLConnection (ConnPtr conn)) (PrepareStatement str) k = do 156 | res <- mkForeign (FFun "sqlite3_prepare_idr" [FPtr, FString] FPtr) conn str 157 | is_null <- nullPtr res 158 | if (not is_null) then k (Right (SQLitePS (ConnPtr conn) (PSPtr res))) (Right ()) 159 | else do err <- foreignGetError (ConnPtr conn) 160 | k (Left (PSFail (ConnPtr conn))) (Left (StatementError err)) 161 | 162 | handle (SQLitePS (ConnPtr conn) (PSPtr res)) (BindInt pos i) k = do 163 | res <- mkForeign (FFun "sqlite3_bind_int_idr" [FPtr, FInt, FInt] FPtr) conn pos i 164 | is_null <- nullPtr res 165 | if (not is_null) then k (SQLitePS (ConnPtr conn) (PSPtr res)) () 166 | else do err <- foreignGetError (ConnPtr conn) 167 | -- putStrLn $ "BindInt error: " ++ (show err) 168 | k (SQLiteBindFail (ConnPtr conn) (PSPtr res) (BE pos err)) () 169 | 170 | handle (SQLitePS (ConnPtr conn) (PSPtr res)) (BindFloat pos f) k = do 171 | res <- mkForeign (FFun "sqlite3_bind_float_idr" [FPtr, FInt, FFloat] FPtr) conn pos f 172 | is_null <- nullPtr res 173 | if (not is_null) then k (SQLitePS (ConnPtr conn) (PSPtr res)) () 174 | else do err <- foreignGetError (ConnPtr conn) 175 | k (SQLiteBindFail (ConnPtr conn) (PSPtr res) (BE pos err)) () 176 | 177 | handle (SQLitePS (ConnPtr conn) (PSPtr res)) (BindText pos str str_len) k = do 178 | res <- mkForeign (FFun "sqlite3_bind_text_idr" [FPtr, FString, FInt, FInt] FPtr) conn str pos str_len 179 | is_null <- nullPtr res 180 | if (not is_null) then k (SQLitePS (ConnPtr conn) (PSPtr res)) () 181 | else do err <- foreignGetError (ConnPtr conn) 182 | -- putStrLn $ "BindStr error: " ++ (show err) 183 | k (SQLiteBindFail (ConnPtr conn) (PSPtr res) (BE pos err)) () 184 | 185 | handle (SQLitePS (ConnPtr conn) (PSPtr res)) (BindNull pos) k = do 186 | res <- mkForeign (FFun "sqlite3_bind_null_idr" [FPtr, FInt] FPtr) conn pos 187 | is_null <- nullPtr res 188 | if (not is_null) then k (SQLitePS (ConnPtr conn) (PSPtr res)) () 189 | else do err <- foreignGetError (ConnPtr conn) 190 | k (SQLiteBindFail (ConnPtr conn) (PSPtr res) (BE pos err)) () 191 | 192 | -- Ok, I lied, we have to do *some* pass-throughs. But they're not terrible. 193 | handle (SQLiteBindFail conn ps be) (BindInt _ _) k = k (SQLiteBindFail conn ps be) () 194 | handle (SQLiteBindFail conn ps be) (BindText _ _ _) k = k (SQLiteBindFail conn ps be) () 195 | handle (SQLiteBindFail conn ps be) (BindFloat _ _) k = k (SQLiteBindFail conn ps be) () 196 | handle (SQLiteBindFail conn ps be) (BindNull _) k = k (SQLiteBindFail conn ps be) () 197 | 198 | 199 | -- Finishing binding, reporting any bind errors if they occurred 200 | handle (SQLitePS c p) (FinishBind) k = 201 | k (Right (SQLitePS c p)) Nothing 202 | 203 | handle (SQLiteBindFail c ps be) (FinishBind) k = 204 | k (Left (SQLiteFBFail c ps)) (Just (BindingError be)) 205 | 206 | handle (SQLitePS (ConnPtr c) (PSPtr p)) (ExecuteStatement) k = do 207 | step <- foreignNextRow (ConnPtr c) 208 | case step of 209 | StepComplete => k (Right (SQLiteE (ConnPtr c) (PSPtr p))) step 210 | StepFail => k (Left (SQLiteE (ConnPtr c) (PSPtr p))) step 211 | NoMoreRows => k (Left (SQLiteE (ConnPtr c) (PSPtr p))) step 212 | 213 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (RowStep) k = do 214 | step <- foreignNextRow (ConnPtr c) 215 | case step of 216 | StepComplete => k (Right (SQLiteE (ConnPtr c) (PSPtr p))) step 217 | StepFail => k (Left (SQLiteE (ConnPtr c) (PSPtr p))) step 218 | NoMoreRows => k (Left (SQLiteE (ConnPtr c) (PSPtr p))) step 219 | 220 | 221 | -- Getting values from the current row 222 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnName i) k = do 223 | res <- mkForeign (FFun "sqlite3_column_name_idr" [FPtr, FInt] FString) c i 224 | k (SQLiteE (ConnPtr c) (PSPtr p)) res 225 | 226 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnDataSize i) k = do 227 | res <- mkForeign (FFun "sqlite3_column_bytes_idr" [FPtr, FInt] FInt) c i 228 | k (SQLiteE (ConnPtr c) (PSPtr p)) res 229 | 230 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnInt i) k = do 231 | res <- mkForeign (FFun "sqlite3_column_int_idr" [FPtr, FInt] FInt) c i 232 | k (SQLiteE (ConnPtr c) (PSPtr p)) res 233 | 234 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnText i) k = do 235 | res <- mkForeign (FFun "sqlite3_column_text_idr" [FPtr, FInt] FString) c i 236 | k (SQLiteE (ConnPtr c) (PSPtr p)) res 237 | 238 | -- Resetting our position 239 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (Reset) k = do 240 | mkForeign (FFun "sqlite3_reset_idr" [FPtr] FInt) c 241 | step <- foreignNextRow (ConnPtr c) 242 | case step of 243 | StepComplete => k (Right (SQLiteE (ConnPtr c) (PSPtr p))) step 244 | StepFail => k (Left (SQLiteE (ConnPtr c) (PSPtr p))) step 245 | NoMoreRows => k (Left (SQLiteE (ConnPtr c) (PSPtr p))) step 246 | 247 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (ResetFromEnd) k = do 248 | mkForeign (FFun "sqlite3_reset_idr" [FPtr] FInt) c 249 | step <- foreignNextRow (ConnPtr c) 250 | case step of 251 | StepComplete => k (Right (SQLiteE (ConnPtr c) (PSPtr p))) step 252 | StepFail => k (Left (SQLiteE (ConnPtr c) (PSPtr p))) step 253 | NoMoreRows => k (Left (SQLiteE (ConnPtr c) (PSPtr p))) step 254 | 255 | -- Finalising the SQL Statement 256 | handle (SQLiteE c p) (FinaliseValid) k = do 257 | foreignFinalise c 258 | k (SQLConnection c) () 259 | 260 | handle (SQLiteE c p) (FinaliseInvalid) k = do 261 | foreignFinalise c 262 | k (SQLConnection c) () 263 | 264 | handle (PSFail c) CleanupPSFail k = do 265 | foreignClose c 266 | k () () 267 | 268 | handle (SQLiteFBFail c p) CleanupBindFail k = do 269 | foreignFinalise c 270 | foreignClose c 271 | k () () 272 | 273 | 274 | SQLITE : Type -> EFFECT 275 | SQLITE t = MkEff t Sqlite 276 | {- User-facing functions -} 277 | openDB : DBName -> EffM IO [SQLITE ()] [SQLITE (Either () SQLiteConnected)] 278 | (Either QueryError ()) 279 | openDB name = (OpenDB name) 280 | 281 | closeDB : EffM IO [SQLITE (SQLiteConnected)] [SQLITE ()] () 282 | closeDB = CloseDB 283 | 284 | prepareStatement : QueryString -> EffM IO [SQLITE SQLiteConnected] 285 | [SQLITE (Either SQLitePSFail 286 | (SQLitePSSuccess Binding))] 287 | (Either QueryError ()) 288 | prepareStatement stmt = (PrepareStatement stmt) 289 | 290 | bindInt : ArgPos -> Int -> Eff IO [SQLITE (SQLitePSSuccess Binding)] () 291 | bindInt pos i = (BindInt pos i) 292 | 293 | bindFloat : ArgPos -> Float -> Eff IO [SQLITE (SQLitePSSuccess Binding)] () 294 | bindFloat pos f = (BindFloat pos f) 295 | 296 | bindText : ArgPos -> String -> Eff IO [SQLITE (SQLitePSSuccess Binding)] () 297 | bindText pos str = (BindText pos str str_len) 298 | where natToInt : Nat -> Int 299 | natToInt Z = 0 300 | natToInt (S k) = 1 + (natToInt k) 301 | 302 | str_len : Int 303 | str_len = natToInt (length str) 304 | 305 | bindNull : ArgPos -> Eff IO [SQLITE (SQLitePSSuccess Binding)] () 306 | bindNull pos = (BindNull pos) 307 | 308 | finishBind : EffM IO [SQLITE (SQLitePSSuccess Binding)] 309 | [SQLITE (Either SQLiteFinishBindFail (SQLitePSSuccess Bound))] 310 | (Maybe QueryError) 311 | finishBind = FinishBind 312 | 313 | nextRow : EffM IO [SQLITE (SQLiteExecuting ValidRow)] 314 | [SQLITE (Either (SQLiteExecuting InvalidRow) 315 | (SQLiteExecuting ValidRow))] StepResult 316 | nextRow = RowStep 317 | 318 | reset : EffM IO [SQLITE (Either (SQLiteExecuting InvalidRow) (SQLiteExecuting ValidRow))] 319 | [SQLITE (Either (SQLiteExecuting InvalidRow) 320 | (SQLiteExecuting ValidRow))] StepResult 321 | reset = if_left then ResetFromEnd else Reset 322 | 323 | 324 | getColumnName : Column -> Eff IO [SQLITE (SQLiteExecuting ValidRow)] String 325 | getColumnName col = (GetColumnName col) 326 | 327 | getColumnText: Column -> Eff IO [SQLITE (SQLiteExecuting ValidRow)] String 328 | getColumnText col = (GetColumnText col) 329 | 330 | getColumnInt : Column -> Eff IO [SQLITE (SQLiteExecuting ValidRow)] Int 331 | getColumnInt col = (GetColumnInt col) 332 | 333 | getColumnDataSize : Column -> Eff IO [SQLITE (SQLiteExecuting ValidRow)] Int 334 | getColumnDataSize col = (GetColumnDataSize col) 335 | 336 | finaliseValid : EffM IO [SQLITE (SQLiteExecuting ValidRow)] [SQLITE (SQLiteConnected)] () 337 | finaliseValid = FinaliseValid 338 | 339 | finaliseInvalid : EffM IO [SQLITE (SQLiteExecuting InvalidRow)] [SQLITE (SQLiteConnected)] () 340 | finaliseInvalid = FinaliseInvalid 341 | 342 | --isOne : (a : Type) -> Either a b 343 | 344 | finalise : EffM IO [SQLITE (Either (SQLiteExecuting InvalidRow) (SQLiteExecuting ValidRow))] 345 | [SQLITE (SQLiteConnected)] () 346 | finalise = if_valid then finaliseValid else finaliseInvalid 347 | 348 | cleanupPSFail : EffM IO [SQLITE (SQLitePSFail)] [SQLITE ()] () 349 | cleanupPSFail = CleanupPSFail 350 | 351 | cleanupBindFail : EffM IO [SQLITE (SQLiteFinishBindFail)] [SQLITE ()] () 352 | cleanupBindFail = CleanupBindFail 353 | 354 | -- Just makes it a tad nicer to write 355 | executeStatement : EffM IO [SQLITE (SQLitePSSuccess Bound)] 356 | [SQLITE (Either (SQLiteExecuting InvalidRow) 357 | (SQLiteExecuting ValidRow))] StepResult 358 | executeStatement = ExecuteStatement 359 | 360 | 361 | getQueryError : Either QueryError b -> QueryError 362 | getQueryError (Left qe) = qe 363 | getQueryError _ = InternalError 364 | 365 | 366 | multiBind' : List (Int, DBVal) -> Eff IO [SQLITE (SQLitePSSuccess Binding)] () 367 | multiBind' [] = Effects.pure () 368 | multiBind' ((pos, (DBInt i)) :: xs) = do bindInt pos i 369 | multiBind' xs 370 | multiBind' ((pos, (DBFloat f)) :: xs) = do bindFloat pos f 371 | multiBind' xs 372 | multiBind' ((pos, (DBText t)) :: xs) = do bindText pos t 373 | multiBind' xs 374 | -- Binds multiple values within a query 375 | multiBind : List (Int, DBVal) -> 376 | EffM IO [SQLITE (SQLitePSSuccess Binding)] 377 | [SQLITE (Either (SQLiteFinishBindFail) (SQLitePSSuccess Bound))] 378 | (Maybe QueryError) 379 | multiBind vals = do 380 | multiBind' vals 381 | finishBind 382 | 383 | 384 | 385 | getRowCount' : StepResult -> EffM IO [SQLITE (Either (SQLiteExecuting InvalidRow) (SQLiteExecuting ValidRow))] 386 | [SQLITE ()] 387 | (Either QueryError Int) 388 | getRowCount' id_res = do 389 | if_valid then do 390 | last_insert_id <- getColumnInt 0 391 | finaliseValid 392 | closeDB 393 | return $ Right last_insert_id 394 | else do finaliseInvalid 395 | closeDB 396 | case id_res of 397 | NoMoreRows => return $ Left (ExecError "Unable to get row count") 398 | StepFail => return $ Left (ExecError "Error whilst getting row count") 399 | 400 | getBindError : Maybe QueryError -> QueryError 401 | getBindError (Just (BindingError be)) = (BindingError be) 402 | getBindError _ = InternalError 403 | 404 | 405 | getRowCount : EffM IO [SQLITE (SQLiteConnected)] [SQLITE ()] (Either QueryError Int) 406 | getRowCount = do 407 | let insert_id_sql = "SELECT last_insert_rowid()" 408 | sql_prep_res <- prepareStatement insert_id_sql 409 | if_valid then do 410 | bind_res_2 <- finishBind 411 | if_valid then do 412 | exec_res <- executeStatement 413 | getRowCount' exec_res 414 | else do 415 | let be = getBindError bind_res_2 416 | cleanupBindFail 417 | return $ Left be 418 | else do 419 | cleanupPSFail 420 | return $ Left (getQueryError sql_prep_res) 421 | 422 | 423 | 424 | executeInsert : String -> 425 | String -> 426 | List (Int, DBVal) -> 427 | Eff IO [SQLITE ()] (Either QueryError Int) 428 | executeInsert db_name query bind_vals = do 429 | db_res <- openDB db_name 430 | if_valid then do 431 | ps_res <- prepareStatement query 432 | if_valid then do 433 | bind_res <- multiBind bind_vals 434 | if_valid then do 435 | er_1 <- executeStatement 436 | finalise 437 | case er_1 of 438 | StepFail => do closeDB 439 | return $ Left (ExecError "Error inserting") 440 | Unstarted => do closeDB 441 | return $ Left (ExecError "Internal error: 'Unstarted' after execution") 442 | _ => getRowCount 443 | else do 444 | let be = getBindError bind_res 445 | cleanupBindFail 446 | return $ Left be 447 | else do 448 | cleanupPSFail 449 | return $ Left (getQueryError ps_res) 450 | else 451 | return $ Left (getQueryError db_res) 452 | 453 | 454 | -- Helper functions for selection from a DB 455 | collectResults : (Eff IO [SQLITE (SQLiteExecuting ValidRow)] (List DBVal)) -> 456 | EffM IO [SQLITE (Either (SQLiteExecuting InvalidRow) 457 | (SQLiteExecuting ValidRow))] 458 | [SQLITE (SQLiteExecuting InvalidRow)] ResultSet 459 | collectResults fn = do 460 | if_valid then do 461 | results <- fn 462 | step_res <- nextRow 463 | xs <- collectResults fn 464 | return $ results :: xs 465 | else return [] 466 | 467 | 468 | -- Convenience function to abstract around some of the boilerplate code. 469 | -- Takes in the DB name, query, a list of (position, variable value) tuples, 470 | -- a function to process the returned data, 471 | executeSelect : String -> 472 | String -> 473 | List (Int, DBVal) -> 474 | (Eff IO [SQLITE (SQLiteExecuting ValidRow)] (List DBVal)) -> 475 | Eff IO [SQLITE ()] (Either QueryError ResultSet) 476 | executeSelect db_name q bind_vals fn = do 477 | conn_res <- openDB db_name 478 | if_valid then do 479 | ps_res <- prepareStatement q 480 | if_valid then do 481 | bind_res <- multiBind bind_vals 482 | if_valid then do 483 | executeStatement 484 | res <- collectResults fn 485 | finaliseInvalid 486 | closeDB 487 | return $ Right res 488 | else do 489 | let be = getBindError bind_res 490 | cleanupBindFail 491 | return $ Left be 492 | else do 493 | cleanupPSFail 494 | return $ Left (getQueryError ps_res) 495 | else 496 | return $ Left (getQueryError conn_res) 497 | 498 | -- Helper function for when there's no binding needed to the PS 499 | -- noBinds : EffM IO [SQLITE ( 500 | -------------------------------------------------------------------------------- /src/IdrisWeb/DB/SQLite/SQLiteTest.idr: -------------------------------------------------------------------------------- 1 | --module IdrisWeb.DB.SQLite.SQLiteTest 2 | module Main 3 | import Effects 4 | import SQLiteNew 5 | import SQLiteCodes 6 | 7 | 8 | testInsert : String -> Int -> EffM IO [SQLITE ()] [SQLITE ()] (Either SQLiteCode ()) 9 | testInsert name age = do 10 | open_db <- openDB "test.db" 11 | if_valid then do 12 | let sql = "INSERT INTO `test` (`name`, `age`) VALUES (?, ?);" 13 | prep_res <- prepareStatement sql 14 | if_valid then do 15 | bindText 1 name 16 | bindInt 2 age 17 | bind_res <- finishBind 18 | if_valid then do 19 | executeStatement 20 | finalise 21 | closeDB 22 | Effects.pure $ Right () 23 | else do 24 | cleanupBindFail 25 | Effects.pure $ (Left (-1)) 26 | else do 27 | cleanupPSFail 28 | -- let (Left err) = prep_res 29 | Effects.pure $ Left (-2) 30 | else do 31 | -- let (Left err) = open_db 32 | Effects.pure $ Left (-3) 33 | 34 | 35 | collectResults : EffM IO [SQLITE (Either (SQLiteExecuting InvalidRow) 36 | (SQLiteExecuting ValidRow))] 37 | [SQLITE (SQLiteExecuting InvalidRow)] 38 | (List (String, Int)) 39 | collectResults = 40 | if_valid then do 41 | name <- getColumnText 0 42 | age <- getColumnInt 1 43 | step_result <- nextRow 44 | xs <- collectResults 45 | Effects.pure $ (name, age) :: xs 46 | else Effects.pure [] 47 | 48 | {- 49 | step_result <- nextRow 50 | case step_result of 51 | StepComplete => do name <- getColumnText 1 52 | age <- getColumnInt 2 53 | xs <- collectResults 54 | Effects.pure $ (name, age) :: xs 55 | NoMoreRows => Effects.pure [] 56 | StepFail => Effects.pure [] 57 | -} 58 | 59 | 60 | testSelect : Eff IO [SQLITE ()] (Either Int (List (String, Int))) 61 | testSelect = do 62 | open_db <- openDB "test.db" 63 | if_valid then do 64 | let sql = "SELECT * FROM `test`;" 65 | sql_prep_res <- prepareStatement sql 66 | if_valid then do 67 | finishBind 68 | if_valid then do 69 | executeStatement 70 | results <- collectResults 71 | finaliseInvalid 72 | closeDB 73 | Effects.pure $ Right results 74 | else do cleanupBindFail 75 | Effects.pure $ Left (-1) 76 | else do cleanupPSFail 77 | Effects.pure $ Left (-2) 78 | else Effects.pure $ Left (-3) 79 | 80 | main : IO () 81 | main = do select_res <- run [()] testSelect 82 | case select_res of 83 | Left err => putStrLn $ "Error: " ++ (show err) 84 | Right results => do traverse (putStrLn . show) results 85 | pure () 86 | 87 | 88 | {- 89 | main : IO () 90 | main = do insert_res <- run [()] (testInsert "Simon" 21) 91 | case insert_res of 92 | Left err => putStrLn $ "Error inserting" ++ (show err) 93 | Right _ => putStrLn $ "Operation completed successfully." 94 | -} 95 | 96 | 97 | -------------------------------------------------------------------------------- /src/IdrisWeb/Form/FormTest.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | --module IdrisWeb.Form.FormTest 3 | import Cgi 4 | import Effects 5 | --import Debug.Trace 6 | 7 | total 8 | outputCommaList : List String -> String 9 | outputCommaList [] = "" 10 | outputCommaList [x] = x ++ "." 11 | outputCommaList (x :: y :: []) = x ++ " and " ++ y ++ "." 12 | outputCommaList (x :: xs) = x ++ ", " ++ outputCommaList xs 13 | 14 | sampleHandler : Maybe String -> 15 | Maybe Int -> 16 | FormHandler [CGI (InitialisedCGI TaskRunning), SQLITE ()] 17 | sampleHandler (Just name) (Just age) = do (output ("Your name is: " ++ name ++ 18 | ", and you are " ++ (show age) ++ " years old!")) 19 | pure () 20 | sampleHandler _ _ = do output "There was an error processing form data." 21 | pure () 22 | 23 | sampleHandler2 : Maybe String -> 24 | Maybe Int -> 25 | FormHandler [CGI (InitialisedCGI TaskRunning), SQLITE ()] 26 | sampleHandler2 (Just name) (Just age) = do (output ("Your name is: " ++ name ++ 27 | ", and you are " ++ (show age) ++ " years old!")) 28 | pure () 29 | sampleHandler2 _ _ = do output "There was an error processing form data." 30 | pure () 31 | 32 | -- Some syntax macro magic might be nice here 33 | handlers : HandlerList 34 | handlers = [(([FormString, FormInt], [CgiEffect, SqliteEffect]) ** (sampleHandler, "sampleHandler")), 35 | (([FormString, FormInt], [CgiEffect, SqliteEffect]) ** (sampleHandler2, "sampleHandler2"))] 36 | 37 | sampleForm : UserForm --UserForm 38 | sampleForm = do addTextBox "Name: " FormString (Just "Simon") 39 | addTextBox "Age: " FormInt Nothing-- 21 40 | useEffects [CgiEffect, SqliteEffect] 41 | addSubmit sampleHandler handlers 42 | 43 | 44 | cgiAction : CGIProg [] () 45 | cgiAction = do output "

Simon's awesome sauce form stuff!

\n" 46 | handlervar <- queryPostVar "handler" 47 | post_vars <- getPOSTVars 48 | let post_vars_str = foldr (\(k, v), str => str ++ k ++ " :-> " ++ v ++ "
") "" post_vars 49 | output "Post vars:
" 50 | output post_vars_str 51 | --sequence (map (\(name, val) => output $ "Name: " ++ name ++ ", " ++ val ++ "
") post_vars) 52 | case handlervar of 53 | -- If at all poss, this needs to be cleaner. Users shouldn't have to type this 54 | Just _ => do res <- handleForm handlers 55 | pure () 56 | Nothing => do addForm "sampleForm" "formtest" sampleForm 57 | pure () 58 | main : IO () 59 | main = do runCGI [initCGIState] cgiAction 60 | pure () 61 | -------------------------------------------------------------------------------- /src/IdrisWeb/Form/FormTypes.idr: -------------------------------------------------------------------------------- 1 | -- File containing all types used in form processing, and associated instances 2 | module IdrisWeb.Form.FormTypes 3 | import Decidable.Equality 4 | import SQLite 5 | import Parser 6 | %access public 7 | 8 | -------------------------------------------------------------------------------- /src/IdrisWeb/Form/frmtest.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | import Effects 3 | import SQLite 4 | import CgiTypes 5 | 6 | -- We could also have SQLITE, or CGI here perhaps 7 | sampleHandler : Maybe String -> Maybe Int -> Maybe Int -> FormHandler [CGI (InitialisedCGI TaskRunning)] Bool 8 | sampleHandler (Just name) (Just age) (Just num) = ((output ("Your name is " ++ name 9 | ++ " and you are " ++ (show age) ++ " years old. You selected: " ++ (show num))) >>= (\_ pure True)) 10 | sampleHandler _ _ _ = output "There was an error processing input data." >>= (\_ => pure False) 11 | 12 | 13 | -- Effects.>>= : (EffM m xs xs' a) -> (a -> EffM m xs' xs'' b) -> EffM xs xs'' b 14 | -- addTextBox str >>= addTextBox int : EffM m [] [FormString] () -> EffM m [FormString] [FormInt, FormString] () -> EffM m [] [FormInt, FormString] 15 | myForm : UserForm 16 | myForm = do addTextBox FormString "Simon" 17 | addTextBox FormInt 21 18 | addSelectionBox FormInt [1,2,3,4] ["One", "Two", "Three", "Four"] 19 | addSubmit sampleHandler [CgiEffect] FormBool 20 | --(addTextBox FormString "Simon") >>= ((\_ => addTextBox FormInt 21) >>= (\_ => addSubmit sampleHandler)) 21 | 22 | 23 | 24 | 25 | main : IO () 26 | main = do let ser_form = mkForm "myform" myForm 27 | putStrLn ser_form 28 | 29 | -------------------------------------------------------------------------------- /src/IdrisWeb/GCrypt/GCrypt.idr: -------------------------------------------------------------------------------- 1 | module GCrypt 2 | import Effects 3 | 4 | %link C "gcrypt_idr.o" 5 | %include C "gcrypt_idr.h" 6 | %lib C "gcrypt" 7 | 8 | -- Unimplemented. Eventually, this should encapsulate the flags 9 | -- available to message digest contexts, which this library could 10 | -- OR together. 11 | HashFlag : Type 12 | HashFlag = Int 13 | 14 | GCryptResult : Type 15 | GCryptResult = Int 16 | 17 | data GCryptStep = GCryptLibInitialised -- Lib initialised 18 | | GCryptMDInitialised -- Message digest context initialised 19 | | GCryptMDWritten -- Message digest context has written out the digest 20 | 21 | data GCryptRes : Step -> Type where 22 | LibInitialised : GCryptHashRes s 23 | -- IOExcept would avoid the need for this... 24 | LibInitFailed : GCryptHashRes s 25 | HashContextInitialised : Ptr -> GCryptHashRes s 26 | HashContextInvalid : GCryptHashRes s 27 | 28 | 29 | data GCrypt : Effect where 30 | -- Currently, marshalling a null pointer to a string results in a segfault. 31 | -- For now, we'll treat this as a bool... 32 | InitialiseGCrypt : Maybe String -> GCrypt () (GCryptRes GCryptLibInitialised) (Bool) -- (Maybe String) 33 | InitialiseHashContext : HashAlgorithm -> List HashFlag -> GCrypt (GCryptRes GCryptLibInitialised) 34 | (GCryptRes GCryptMDInitialised) 35 | (Bool) 36 | {- Not really needed. 37 | FinaliseHashContext : GCrypt (GCryptRes GCryptMDInitialised) 38 | (GCryptRes GCryptMDFinalised) 39 | () 40 | -} 41 | 42 | DisposeHashContext : GCrypt (GCryptRes GCryptMDWritten) 43 | (GCryptRes GCryptLibInitialised) 44 | () 45 | 46 | ResetHashContext : GCrypt (GCryptRes GCryptMDWritten) 47 | (GCryptRes GCryptMDInitialised) 48 | () 49 | 50 | -- Strings only for now. It'd be nice to get the full AoB thing going, but that might take a bit 51 | -- of FFI rewriting... 52 | GetStringMessageDigest : String -> GCrypt (GCryptRes GCryptMDInitialised) 53 | (GCryptRes GCryptMDWritten) 54 | (String) 55 | 56 | GCRYPT : Type -> EFFECT 57 | GCRYPT t = MkEff t GCrypt 58 | 59 | {- Functions -} 60 | initialiseGCrypt : Maybe String -> EffM IO [GCRYPT ()] [GCRYPT (GCryptRes GCryptLibInitialised)] Bool -- (Maybe String) 61 | initialiseGCrypt ver = (InitialiseGCrypt ver) 62 | 63 | -- Initialises a hash context within the library, given an algorithm and a list of flags. 64 | initialiseHashContext : HashAlgorithm -> List HashFlag -> EffM [GCRYPT (GCryptRes GCryptLibInitialised)] 65 | [GCRYPT (GCryptRes GCryptMDInitialised)] 66 | (Bool) 67 | initialiseHashContext alg flags = (InitialiseHashContext alg flags) 68 | 69 | -- Disposes of a hash context, freeing associated resources 70 | disposeHashContext : EffM IO [GCRYPT (GCryptRes GCryptMDWritten)] 71 | [GCRYPT (GCryptRes GCryptLibInitialised)] 72 | () 73 | disposeHashContext = DisposeHashContext 74 | 75 | -- Resets a hash context 76 | resetHashContext : EffM IO [GCRYPT (GCryptRes GCryptMDWritten)] 77 | [GCRYPT (GCryptRes GCryptMDInitialised)] 78 | () 79 | resetHashContext = ResetHashContext 80 | 81 | -- Gets the message digest of a string, using one of the 82 | -- BIG TODO: Tactic to ensure that the given hash algorithm is available 83 | getStringMessageDigest : String -> EffM IO [GCRYPT (GCryptRes GCryptMDInitialised)] 84 | [GCRYPT (GCryptRes GCryptMDWritten)] 85 | (String) 86 | getStringMessageDigest str = (GetStringMessageDigest str) 87 | 88 | 89 | cleanupResStruct : Ptr -> IO () 90 | cleanupResStruct ptr = do 91 | res <- mkForeign (FFun "idris_gcry_dispose_res" [FPtr] FUnit) ptr 92 | pure () 93 | 94 | instance Handler GCrypt IO where 95 | handle () (InitialiseGCrypt (Just ver)) k = do 96 | res <- mkForeign (FFun "idris_gcry_init" [FString] FPtr) ver 97 | null_res <- isNull res 98 | if null_res then 99 | k (LibInitFailed) False 100 | else 101 | k (LibInitialised) True 102 | 103 | handle () (InitialiseGCrypt Nothing) k = do 104 | res <- mkForeign (FFun "idris_gcry_init" [FString] FPtr) "" 105 | null_res <- isNull res 106 | if null_res then 107 | k (LibInitFailed) False 108 | else 109 | k (LibInitialised) True 110 | 111 | handle (LibInitialised) (InitialiseHashContext alg flags) = do 112 | -- TODO: We're ignoring flags for now 113 | res <- mkForeign (FFun "idris_gcry_init_md" [FInt, FInt] FPtr) alg 0 114 | -- Res is a structure demonstrating the result code and a pointer 115 | -- which may, so long as the call was correct, point to a hashing 116 | -- context. The intermediate library will not return NULL here. 117 | err <- mkForeign (FFun "idris_gcry_get_struct_err" [FPtr] FInt) res 118 | -- Once again, I'm quickly hacking around this. The error value returned 119 | -- by LibGCrypt consists of two distinct parts: the error code, and the 120 | -- error location. If, however, the operation was successful, then the 121 | -- whole thing will be 0. 122 | -- Expect this interface to change when I do it properly. 123 | if err == 0 then do 124 | -- Success 125 | context <- mkForeign (FFun "idris_gcry_get_struct_data" [FPtr] FPtr) res 126 | -- Prudent to do a null check in case something's gone wrong 127 | context_null <- isNull context 128 | cleanupResStruct res 129 | if context_null then do 130 | k (HashContextInvalid) Nothing 131 | else 132 | k (HashContextInitialised context) 133 | else 134 | k (HashContextInvalid) Nothing 135 | -------------------------------------------------------------------------------- /src/IdrisWeb/GCrypt/gcrypt_idr.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include "gcrypt_idr.h" 7 | 8 | // LibGCrypt bindings for Idris. Provides a layer between the 9 | // Idris code and the GCrypt code, to provide convenience functions 10 | // and datatype marshalling. 11 | 12 | 13 | 14 | // Initialises the libgcrypt library. 15 | // A required version may be specified: if this is 16 | // the empty string, then GCRYPT_VERSION will be used instead. 17 | const char* idris_gcry_init(const char* version) { 18 | const char* ret; 19 | if (strlen(version) >= 0) { 20 | ret = gcry_check_version(version); 21 | } else { 22 | ret = gcry_check_version(GCRYPT_VERSION); 23 | } 24 | 25 | if (ret) { 26 | // We're ignoring secure memory for the moment, 27 | // although it may be good to add in future. 28 | gcry_control (GCRYCTL_DISABLE_SECMEM, 0); 29 | gcry_control (GCRYCTL_INITIALIZATION_FINISHED, 0); 30 | } 31 | return ret; 32 | } 33 | 34 | // Returns the gcry_error_t value from a call 35 | gcry_error_t idris_gcry_get_struct_err(void* gcry_res_struct) { 36 | idris_gcry_res* struct_ptr = (idris_gcry_res*) gcry_res_struct; 37 | return struct_ptr->err; 38 | } 39 | 40 | // Returns the data associated with a call 41 | void* idris_gcry_get_struct_data(void* gcry_res_struct) { 42 | idris_gcry_res* struct_ptr = (idris_gcry_res*) gcry_res_struct; 43 | return struct_ptr->res; 44 | } 45 | 46 | // Frees the result of an idris_grcy_res struct 47 | void idris_gcry_dispose_res(void* gcry_res_struct) { 48 | free(gcry_res_struct); 49 | } 50 | 51 | // Initialises a result structure, setting the initial value of the data ptr to NULL 52 | idris_gcry_res* init_res_struct() { 53 | idris_gcry_res* ret = malloc(sizeof(idris_gcry_res)); 54 | ret->res = NULL; 55 | return ret; 56 | } 57 | 58 | // Opens a hashing context 59 | // TODO: flags should be more idris-friendly... Maybe an array? 60 | void* idris_gcry_init_md(int algorithm_key, unsigned int flags) { 61 | idris_gcry_res* result_struct = init_res_struct(); 62 | // Allocate the context memory, perform the call 63 | gcry_md_hd_t* context = malloc(sizeof(gcry_md_hd_t)); 64 | gcry_error_t err = gcry_md_open(context, algorithm_key, flags); 65 | // Populate the result struct, return 66 | result_struct->err = err; 67 | result_struct->res = context; 68 | return result_struct; 69 | } 70 | 71 | gcry_error_t idris_gcry_enable_algorithm(void* context, int algorithm_key) { 72 | // Firstly, cast back to gcry_md_hd_t* 73 | gcry_md_hd_t* context_ptr = (gcry_md_hd_t*) context; 74 | // Perform the computation, return 75 | return gcry_md_enable(*context_ptr, algorithm_key); 76 | } 77 | 78 | void idris_gcry_dispose_md(void* context) { 79 | if (context != NULL) { 80 | gcry_md_hd_t* context_ptr = (gcry_md_hd_t*) context; 81 | gcry_md_close(*context_ptr); 82 | free(context_ptr); 83 | } 84 | } 85 | 86 | void idris_gcry_reset_md(void* context) { 87 | if (context != NULL) { 88 | gcry_md_hd_t* context_ptr = (gcry_md_hd_t*) context; 89 | gcry_md_reset(*context_ptr); 90 | } 91 | } 92 | 93 | // Just as a POC, I'm going to just have a string hashing function, 94 | // as opposed to hashing arbitrary data. 95 | // In the same vein, we return a textual representation of the digest 96 | // as opposed to the bitstring. 97 | // I'll get round to doing it properly at some stage... 98 | char* idris_hash_string(void* context, char* str, int algorithm_key) { 99 | gcry_md_hd_t* context_ptr = (gcry_md_hd_t*) context; 100 | int str_len = strlen(str); 101 | // Get the buffer length required to store the digest 102 | unsigned int digest_length = gcry_md_get_algo_dlen(algorithm_key); 103 | //void* output_buffer = malloc(digest_length); 104 | // Put the bytes into the context 105 | gcry_md_write(*context_ptr, (const void*) str, str_len); 106 | // Read the digest into output_buffer; 107 | unsigned char* output = gcry_md_read(*context_ptr, algorithm_key); 108 | char* str_output = malloc((digest_length * 2) + 1); // * [digest_length + 1]; 109 | for (int i = 0; i < digest_length; i++) { 110 | sprintf(&str_output[i * 2], "%2.2x", output[i]); 111 | //printf("%2.2x", output[i]); //str_output[i]); 112 | } 113 | str_output[(digest_length * 2) + 1] = 0x00; // terminate it properly 114 | return str_output; 115 | } 116 | 117 | /* 118 | int main(int argc, char** argv) { 119 | if (argc < 2) { 120 | printf("Usage: thing [arg]"); 121 | exit(0); 122 | } 123 | 124 | char* input = argv[1]; 125 | if (idris_gcry_init(NULL)) { 126 | //GCRY_MD_SHA256 127 | void* res_struct = idris_gcry_init_md(GCRY_MD_SHA256, 0); 128 | void* context = ((idris_gcry_res*) res_struct)->res; 129 | char* output = idris_hash_string(context, input, GCRY_MD_SHA256); 130 | idris_gcry_dispose_md(context); 131 | printf("%s\n", output); 132 | } else { 133 | fprintf(stderr, "Failed to initialise"); 134 | } 135 | } 136 | */ 137 | -------------------------------------------------------------------------------- /src/IdrisWeb/GCrypt/gcrypt_idr.h: -------------------------------------------------------------------------------- 1 | #ifndef IDRIS_GCRYPT_H 2 | #define IDRIS_GCRYPT_H 3 | 4 | typedef struct idris_gcry_res { 5 | gcry_error_t err; 6 | void* res; 7 | } idris_gcry_res; 8 | 9 | const char* idris_gcry_init(const char* version); 10 | gcry_error_t idris_gcry_get_struct_err(void* gcry_res_struct); 11 | void* idris_gcry_get_struct_data(void* gcry_res_struct); 12 | void idris_gcry_dispose(void* gcry_res_struct); 13 | idris_gcry_res* init_res_struct(); 14 | void* idris_gcry_init_md(int algorithm_key, unsigned int flags); 15 | gcry_error_t idris_gcry_enable_algorithm(void* context, int algorithm_key); 16 | void idris_gcry_dispose_md(void* context); 17 | void idris_gcry_reset_md(void* context); 18 | char* idris_hash_string(void* context, char* str, int algorithm_key); 19 | void idris_gcry_dispose_res(void* gcry_res_struct); 20 | 21 | 22 | 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /src/IdrisWeb/Session/Session.idr: -------------------------------------------------------------------------------- 1 | {- IdrisWeb Session System 2 | Makes use of effects library to allow for persistent sessions. 3 | 4 | Exploits to prevent against: 5 | - Fixation 6 | - Session ID *MUST* be regenerated when the user logs in. 7 | - Brute force 8 | - Big numbers, cryptographically secure and random 9 | - Sniffing (also todo: SSL) 10 | - Only allow sessions to be sent over an SSL connection 11 | -} 12 | module IdrisWeb.Session.Session 13 | import IdrisWeb.DB.SQLite.SQLiteNew 14 | import Effects 15 | import IdrisWeb.Common.Random.RandC 16 | import SimpleParser 17 | %access public 18 | 19 | -- SessionID should be some long-ish random string (hash?) 20 | SessionID : Type 21 | SessionID = String 22 | 23 | private 24 | DB_NAME : String 25 | DB_NAME = "/tmp/sessions.db" 26 | 27 | -- I think in this circumstance, tagged data types 28 | -- would be better, since we're not passing directly 29 | -- to a function, more just providing other functions 30 | -- with data. 31 | data SessionDataType = SInt Int 32 | | SString String 33 | | SBool Bool 34 | | SNull 35 | total 36 | showSerialisedVal : SessionDataType -> (String, String) 37 | showSerialisedVal (SInt i) = ("SInt", show i) 38 | showSerialisedVal (SString s) = ("SString", s) 39 | showSerialisedVal (SBool b) = ("SBool", show b) 40 | showSerialisedVal (SNull) = ("SNull", "") 41 | 42 | -- Given a serialised value from the DB, construct 43 | -- the appropriate data type. 44 | -- TODO: Probably a better way of doing it than storing the 45 | -- type as a string in the DB: an enum would likely be better 46 | --total 47 | deserialiseVal : String -> String -> Maybe SessionDataType 48 | deserialiseVal tystr s = 49 | if tystr == "SInt" then case parse int s of 50 | Left err => Nothing 51 | Right (i, _) => Just $ SInt i 52 | else if tystr == "SString" then Just $ SString s 53 | else if tystr == "SBool" then case parse bool s of 54 | Left err => Nothing 55 | Right (b, _) => Just $ SBool b 56 | else if tystr == "SNull" then Just SNull 57 | else Nothing 58 | 59 | -- SerialisedSession is a list of 3-tuples of . 60 | SerialisedSessionEntry : Type 61 | SerialisedSessionEntry = (String, String, String) 62 | 63 | public -- this really shouldn't be public, TODO: change 64 | SerialisedSession : Type 65 | SerialisedSession = List SerialisedSessionEntry 66 | 67 | -- SessionData is the user-facing data type, containing the session names and variables 68 | public 69 | SessionData : Type 70 | SessionData = List (String, SessionDataType) 71 | 72 | {- 73 | deserialiseSession : SerialisedSession -> Maybe SessionData 74 | deserialiseSession ss = sequence $ map (\(key, val, ty) => case (deserialiseVal ty val) of 75 | Just dat => Just (key, dat) 76 | Nothing => Nothing) ss 77 | -} 78 | 79 | deserialiseSession : SerialisedSession -> Maybe SessionData 80 | deserialiseSession ss = traverse (\(key, val, ty) => case (deserialiseVal ty val) of 81 | Just dat => Just (key, dat) 82 | Nothing => Nothing) ss 83 | 84 | 85 | -- showSerialisedVal : (String, String) 86 | serialiseSession : SessionData -> SerialisedSession 87 | serialiseSession sd = map (\(key, sdt) => let (tystr, valstr) = showSerialisedVal sdt in 88 | (key, valstr, tystr)) sd 89 | 90 | 91 | 92 | 93 | -- Retrieves session data as a list of (String, String) k-v pairs. 94 | -- We marshal this back to the required types in a later function. 95 | collectResults : EffM IO [SQLITE (Either (SQLiteExecuting InvalidRow) (SQLiteExecuting ValidRow))] 96 | [SQLITE (SQLiteExecuting InvalidRow)] 97 | SerialisedSession 98 | collectResults = 99 | if_valid then do 100 | key <- getColumnText 0 101 | val <- getColumnText 1 102 | ty <- getColumnText 2 103 | step_result <- nextRow 104 | xs <- collectResults 105 | Effects.pure $ (key, val, ty) :: xs 106 | else Effects.pure [] 107 | 108 | 109 | retrieveSessionData : SessionID -> Eff IO [SQLITE ()] (Either QueryError SerialisedSession) 110 | retrieveSessionData s_id = do 111 | conn_res <- openDB DB_NAME 112 | if_valid then do 113 | let sql = "SELECT key, val, ty FROM `sessiondata` WHERE `session_key` = ?" 114 | ps_res <- prepareStatement sql 115 | if_valid then do 116 | bindText 1 s_id 117 | bind_res <- finishBind 118 | if_valid then do 119 | executeStatement 120 | results <- collectResults 121 | finaliseInvalid 122 | closeDB 123 | Effects.pure $ Right results 124 | else do 125 | let be = getBindError bind_res 126 | cleanupBindFail 127 | Effects.pure $ Left be 128 | else do 129 | cleanupPSFail 130 | Effects.pure . Left $ getQueryError ps_res 131 | else 132 | Effects.pure . Left $ getQueryError conn_res 133 | 134 | --removeSessionData : SessionID -> Eff IO [SQLITE ()] 135 | 136 | getInsertArg : SerialisedSession -> String 137 | getInsertArg [] = "" 138 | -- no comma needed at the end 139 | getInsertArg ((key, val, ty) :: []) = "(\"" ++ key ++ "\", \"" ++ val ++ "\", \"" ++ ty ++ "\")" 140 | getInsertArg ((key, val, ty) :: xs) = "(\"" ++ key ++ "\", \"" ++ val ++ "\", \"" ++ ty ++ "\")" ++ ", " ++ (getInsertArg xs) 141 | 142 | 143 | storeSessionRow : SessionID -> SerialisedSessionEntry -> Eff IO [SQLITE ()] (Either QueryError ()) 144 | storeSessionRow s_id (key, val, ty) = do 145 | conn_res <- openDB DB_NAME 146 | if_valid then do 147 | let insert_sql = "INSERT INTO `sessiondata` (`session_key`, `key`, `val`, `ty`) VALUES (?, ?, ?, ?)" 148 | ps_res <- prepareStatement insert_sql 149 | if_valid then do 150 | -- Bind the arguments to the prepared statement 151 | bindText 1 s_id 152 | bindText 2 key 153 | bindText 3 val 154 | bindText 4 ty 155 | bind_res <- finishBind 156 | if_valid then do 157 | executeStatement 158 | finalise 159 | closeDB 160 | Effects.pure $ Right () 161 | else do 162 | let be = getBindError bind_res 163 | cleanupBindFail 164 | Effects.pure $ Left be 165 | else do 166 | cleanupPSFail 167 | Effects.pure . Left $ getQueryError ps_res 168 | else 169 | Effects.pure . Left $ getQueryError conn_res 170 | 171 | storeSessionData : SessionID -> SerialisedSession -> Eff IO [SQLITE ()] (Either QueryError ()) 172 | storeSessionData s_id [] = Effects.pure $ Right () 173 | storeSessionData s_id (sr :: srs) = do res <- storeSessionRow s_id sr 174 | case res of 175 | Left err => Effects.pure $ Left err 176 | Right () => storeSessionData s_id srs 177 | 178 | removeSession: SessionID -> Eff IO [SQLITE ()] (Either QueryError ()) 179 | removeSession s_id = do 180 | conn_res <- openDB DB_NAME 181 | if_valid then do 182 | let delete_sql = "DELETE FROM `sessiondata` WHERE `session_key` = ?" 183 | ps_res <- prepareStatement delete_sql 184 | if_valid then do 185 | bindText 1 s_id 186 | bind_res <- finishBind 187 | if_valid then do 188 | executeStatement 189 | finalise 190 | closeDB 191 | Effects.pure $ Right () 192 | else do 193 | let be = getBindError bind_res 194 | cleanupBindFail 195 | Effects.pure $ Left be 196 | else do 197 | cleanupPSFail 198 | Effects.pure . Left $ getQueryError ps_res 199 | else 200 | Effects.pure . Left $ getQueryError conn_res 201 | 202 | -- Remove then store 203 | updateSessionData : SessionID -> SessionData -> Eff IO [SQLITE ()] (Either QueryError ()) 204 | updateSessionData s_id sd = do 205 | del_res <- removeSession s_id 206 | case del_res of 207 | Left err => Effects.pure $ Left err 208 | Right () => do store_res <- storeSessionData s_id (serialiseSession sd) 209 | case store_res of 210 | Left err' => Effects.pure $ Left err' 211 | Right () => Effects.pure $ Right () 212 | 213 | 214 | getSession : SessionID -> IO (Maybe SessionData) 215 | getSession s_id = do db_res <- run [()] (retrieveSessionData s_id) 216 | case db_res of 217 | Left err => pure Nothing 218 | Right ss => pure $ deserialiseSession ss 219 | 220 | {- Session effect: 221 | We should be able to create, update and delete sessions. 222 | We should only be able to update and delete valid sessions. 223 | We should only be able to create sessions when we don't have an active session. 224 | We really should only be able to populate a session after authentication 225 | if we generate a new session (in order to prevent session fixation attacks (but how... hmmmm) 226 | -} 227 | 228 | data SessionStep = SessionUninitialised 229 | | SessionInitialised 230 | 231 | public 232 | data SessionRes : SessionStep -> Type where 233 | InvalidSession : SessionRes s 234 | ValidSession : SessionID -> SessionData -> SessionRes s 235 | 236 | 237 | data Session : Effect where 238 | -- Load a session from the database, given a session ID. 239 | LoadSession : SessionID -> Session (SessionRes SessionUninitialised) (SessionRes SessionInitialised) (Maybe SessionData) 240 | -- Updates the in-memory representation of the session 241 | UpdateSession : SessionData -> Session (SessionRes SessionInitialised) (SessionRes SessionInitialised) () 242 | -- Given a session data set, creates a new session 243 | CreateSession : SessionData -> Session (SessionRes SessionUninitialised) (SessionRes SessionInitialised) (Maybe SessionID) 244 | -- Delete the current session 245 | DeleteSession : Session (SessionRes SessionInitialised) (SessionRes SessionUninitialised) Bool -- Hmmm... Error handling? How? 246 | -- Updates the DB with the new session data, discards the in-memory resources 247 | WriteToDB : Session (SessionRes SessionInitialised) (SessionRes SessionUninitialised) Bool 248 | -- Discards changes to the current session, disposes of resources 249 | DiscardSessionChanges : Session (SessionRes SessionInitialised) (SessionRes SessionUninitialised) () 250 | 251 | GetSessionID : Session (SessionRes SessionInitialised) (SessionRes SessionInitialised) (Maybe SessionID) 252 | 253 | GetSessionData : Session (SessionRes SessionInitialised) (SessionRes SessionInitialised) (Maybe SessionData) 254 | 255 | SESSION : Type -> EFFECT 256 | SESSION t = MkEff t Session 257 | 258 | loadSession : SessionID -> EffM m [SESSION (SessionRes SessionUninitialised)] 259 | [SESSION (SessionRes SessionInitialised)] 260 | (Maybe SessionData) 261 | loadSession s_id = (LoadSession s_id) 262 | 263 | updateSession : SessionData -> Eff m [SESSION (SessionRes SessionInitialised)] () 264 | updateSession sd = (UpdateSession sd) 265 | 266 | createSession : SessionData -> EffM m [SESSION (SessionRes SessionUninitialised)] 267 | [SESSION (SessionRes SessionInitialised)] 268 | (Maybe SessionID) 269 | createSession sd = (CreateSession sd) 270 | 271 | deleteSession : EffM m [SESSION (SessionRes SessionInitialised)] 272 | [SESSION (SessionRes SessionUninitialised)] 273 | Bool 274 | deleteSession = DeleteSession 275 | 276 | writeSessionToDB : EffM m [SESSION (SessionRes SessionInitialised)] 277 | [SESSION (SessionRes SessionUninitialised)] 278 | Bool 279 | writeSessionToDB = WriteToDB 280 | 281 | discardSession : EffM m [SESSION (SessionRes SessionInitialised)] 282 | [SESSION (SessionRes SessionUninitialised)] 283 | () 284 | discardSession = DiscardSessionChanges 285 | 286 | getSessionID : Eff m [SESSION (SessionRes SessionInitialised)] 287 | (Maybe SessionID) 288 | getSessionID = GetSessionID 289 | 290 | getSessionData : Eff m [SESSION (SessionRes SessionInitialised)] 291 | (Maybe SessionData) 292 | getSessionData = GetSessionData 293 | 294 | instance Handler Session IO where 295 | -- Grab the session from the DB given the session key. 296 | -- If it exists, construct the resource and return the data. 297 | -- If not, return nothing, and reflect the invalidity in the resource. 298 | 299 | -- This should never happen 300 | handle (ValidSession _ _) (LoadSession _) k = k InvalidSession Nothing 301 | 302 | handle InvalidSession (LoadSession s_id) k = do 303 | maybe_session <- getSession s_id 304 | case maybe_session of 305 | Just s_data => k (ValidSession s_id s_data) (Just s_data) 306 | Nothing => k InvalidSession Nothing 307 | 308 | -- Update the in-memory representation of the session. 309 | handle (ValidSession s_id s_dat) (UpdateSession s_dat') k = 310 | k (ValidSession s_id s_dat') () 311 | 312 | -- If we're trying to update an invalid session, just let it fall 313 | -- through. 314 | handle (InvalidSession) (UpdateSession _) k = 315 | k (InvalidSession) () 316 | 317 | -- Delete a session from the database, and dispose of our resources. 318 | handle (ValidSession s_id _) DeleteSession k = do 319 | delete_res <- run [()] (removeSession s_id) 320 | case delete_res of 321 | Left err => k InvalidSession False 322 | Right () => k InvalidSession True 323 | 324 | handle (InvalidSession) DeleteSession k = k InvalidSession False 325 | 326 | -- Writes a session to the DB, and disposes of the in-memory resources 327 | handle (ValidSession s_id s_dat) WriteToDB k = do 328 | update_res <- run [()] (updateSessionData s_id s_dat) 329 | case update_res of 330 | Left err => do putStrLn (show err) 331 | k InvalidSession False 332 | Right () => k InvalidSession True 333 | 334 | handle InvalidSession WriteToDB k = k InvalidSession False 335 | 336 | -- Simply discard the resource without doing any writes 337 | handle (ValidSession _ _) DiscardSessionChanges k = k InvalidSession () 338 | handle (InvalidSession) DiscardSessionChanges k = k InvalidSession () 339 | 340 | handle (ValidSession _ _) (CreateSession _) k = k InvalidSession Nothing 341 | -- Creates a new session. 342 | -- BIG TODO: This random number gen is extremely rudimentary, and not 343 | -- secure enough for actual use. 344 | -- We've also got no guarantees that the IDs generated will be unique... 345 | -- This can be fixed by having some sort of property variable in the session 346 | -- DB, which we increment each time, and hash alongside the random number. 347 | -- While OK for a quick prototype, this *REALLY* must be fixed. 348 | handle InvalidSession (CreateSession sd) k = do 349 | rand_id <- getRandom 1000000000 21474836476 -- FIXME: This is a pathetic level of entropy... 350 | let s_id = show rand_id -- Some hash function would be here, typically 351 | store_res <- run [()] (storeSessionData s_id (serialiseSession sd)) 352 | case store_res of 353 | Left err' => k InvalidSession Nothing 354 | Right () => k (ValidSession s_id sd) (Just s_id) 355 | 356 | handle (ValidSession s_id s_dat) GetSessionID k = k (ValidSession s_id s_dat) (Just s_id) 357 | handle (ValidSession s_id s_dat) GetSessionData k = k (ValidSession s_id s_dat) (Just s_dat) 358 | handle InvalidSession GetSessionID k = k InvalidSession Nothing 359 | handle InvalidSession GetSessionData k = k InvalidSession Nothing 360 | -------------------------------------------------------------------------------- /src/IdrisWeb/Session/SessionUtils.idr: -------------------------------------------------------------------------------- 1 | module IdrisWeb.Session.SessionUtils 2 | import IdrisWeb.CGI.CgiTypes 3 | import IdrisWeb.CGI.Cgi 4 | import IdrisWeb.Session.Session 5 | import IdrisWeb.DB.SQLite.SQLiteNew 6 | import Effects 7 | %access public 8 | 9 | -- Key for the session id in the cookie 10 | public 11 | SESSION_VAR : String 12 | SESSION_VAR = "session_id" 13 | 14 | getOrCreateSession : EffM IO [CGI (InitialisedCGI TaskRunning), SESSION (SessionRes SessionUninitialised)] 15 | [CGI (InitialisedCGI TaskRunning), SESSION (SessionRes SessionInitialised)] 16 | (Maybe (SessionID, SessionData)) 17 | getOrCreateSession = do 18 | -- Firstly grab the session ID from the cookies, if it exists 19 | s_var <- lift' (queryCookieVar SESSION_VAR) 20 | case s_var of 21 | -- If it does exist, then attempt to load the session 22 | Just s_id => do res <- lift' (loadSession s_id) 23 | case res of 24 | Just res' => Effects.pure $ Just (s_id, res') -- (s_id, res') 25 | -- TODO: This should create a new session 26 | Nothing => Effects.pure $ Nothing 27 | -- If it doesn't, create a new, empty session 28 | Nothing => do res <- lift (Drop (Keep (SubNil))) (createSession []) 29 | case res of 30 | Just s_id' => Effects.pure $ Just (s_id', []) 31 | Nothing => Effects.pure $ Nothing 32 | 33 | setSessionCookie : Eff IO [CGI (InitialisedCGI TaskRunning), SESSION (SessionRes SessionInitialised)] Bool 34 | setSessionCookie = do s_id <- lift (Drop (Keep (SubNil))) getSessionID 35 | case s_id of 36 | Just s_id => do lift (Keep (Drop (SubNil))) (setCookie SESSION_VAR s_id) 37 | pure True 38 | Nothing => pure False 39 | 40 | 41 | total 42 | updateVar : String -> SessionDataType -> SessionData -> SessionData 43 | updateVar new_key new_val [] = [(new_key, new_val)] 44 | updateVar new_key new_val ((key, val)::xs) = if (key == new_key) then ((key, new_val):: xs) 45 | else ((key, val) :: (updateVar new_key new_val xs)) 46 | 47 | 48 | 49 | -- Takes in two functions: one to execute if there is a valid, authenticated 50 | -- session cookie, and one to execute if there isn't. 51 | withSession : (SessionData -> 52 | EffM IO [CGI (InitialisedCGI TaskRunning), 53 | SESSION (SessionRes SessionInitialised), 54 | SQLITE ()] 55 | [CGI (InitialisedCGI TaskRunning), 56 | SESSION (SessionRes SessionUninitialised), 57 | SQLITE ()] ()) -> 58 | EffM IO [CGI (InitialisedCGI TaskRunning), 59 | SESSION (SessionRes SessionInitialised), 60 | SQLITE ()] 61 | [CGI (InitialisedCGI TaskRunning), 62 | SESSION (SessionRes SessionUninitialised), 63 | SQLITE ()] () -> 64 | Eff IO [CGI (InitialisedCGI TaskRunning), 65 | SESSION (SessionRes SessionUninitialised), 66 | SQLITE ()] () 67 | withSession is_auth_fn not_auth_fn = do 68 | s_var <- queryCookieVar SESSION_VAR 69 | case s_var of 70 | -- If it does exist, then attempt to load the session 71 | Just s_id => do res <- loadSession s_id--(lift (Drop (Keep (SubNil))) (loadSession s_id)) 72 | case res of 73 | -- If we've got a valid session, execute the user-specified 74 | -- function with the gathered session data 75 | Just res' => do is_auth_fn res' 76 | pure () 77 | -- If not, execute the specified failure function 78 | Nothing => do not_auth_fn 79 | pure () 80 | -- If there's no session variable, execute the failure function (somehow) 81 | -- HACK: this loadSession won't succeed, yet will transfer into the other state so 82 | -- that the not_auth_fn can be run. Probably better ways of doing it 83 | Nothing => do loadSession "" 84 | not_auth_fn 85 | pure () 86 | 87 | 88 | 89 | 90 | -------------------------------------------------------------------------------- /src/IdrisWeb/Session/sessiondb.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE sessiondata ( 2 | `session_key` TEXT NOT NULL, 3 | `key` TEXT NOT NULL, 4 | `val` TEXT NOT NULL, 5 | `ty` TEXT NOT NULL 6 | ); 7 | -------------------------------------------------------------------------------- /src/MakefileC: -------------------------------------------------------------------------------- 1 | all : rand_c.o sqlite3api.o 2 | 3 | rand_c.o : rand_c.c rand_c.h 4 | gcc -c rand_c.c 5 | 6 | sqlite3api.o : sqlite3api.c sqlite3api.h 7 | gcc -c sqlite3api.c 8 | 9 | 10 | -------------------------------------------------------------------------------- /src/rand_c.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "rand_c.h" 5 | 6 | 7 | /* Massive cop-out so I don't have to mess around doing this in Idris! */ 8 | // Taken from a StackOverflow post by Abhay Budakoti 9 | int random_number(int min_num, int max_num) 10 | { 11 | int result=0,low_num=0,hi_num=0; 12 | if(min_numdb_ptr = db; 37 | return dbi; 38 | 39 | } 40 | /* 41 | Frees the resource and returns 0 on success 42 | */ 43 | int sqlite3_close_idr(void* db){ 44 | 45 | DBinfo* dbi =(DBinfo*) db; 46 | int res =sqlite3_close(dbi->db_ptr); 47 | if (res == SQLITE_OK){ 48 | free(dbi); 49 | return 0; 50 | } 51 | else { 52 | return res; 53 | } 54 | } 55 | /* 56 | SQLite wrapper around sqlite3_prepare_v2(), 57 | sqlite3_step(), and sqlite3_finalize(). 58 | This version of exec cannot be used with prepare. 59 | For executing queries, must use the exec_db function. 60 | */ 61 | int sqlite3_exec_idr(void* db, const char *sql) 62 | { 63 | DBinfo* dbi =(DBinfo*) db; 64 | char* err; 65 | int rc; 66 | rc = sqlite3_exec(dbi->db_ptr,sql,NULL, NULL, &err); 67 | if (rc != SQLITE_OK && err != NULL) { 68 | strncpy(dbi->buffer, err, sizeof(dbi->buffer)); 69 | sqlite3_free(err); 70 | } 71 | return rc; 72 | } 73 | /* 74 | Gets the error store in the buffer 75 | in the struct. Some certain functions 76 | have the feature to store errors in a buffer. 77 | */ 78 | char* sqlite3_get_error(void* db) { 79 | DBinfo* dbi =(DBinfo*) db; 80 | return dbi->buffer; 81 | } 82 | 83 | int idr_errcode(void* db) { 84 | sqlite3* sql_db = (sqlite3*) db; 85 | return sqlite3_errcode(sql_db); 86 | } 87 | 88 | /* 89 | Compiles the query into a byte-code program 90 | Returns a pointer to the sqlite3_stmt pointer 91 | and stores it in the struct. 92 | */ 93 | void* sqlite3_prepare_idr(void *db,const char *zSql){ 94 | sqlite3_stmt* stmt; 95 | const char *tail; 96 | 97 | DBinfo* dbi =(DBinfo*) db; 98 | 99 | int rec = sqlite3_prepare_v2(dbi->db_ptr,zSql,-1,&stmt,&tail); 100 | dbi ->ppStmt =stmt; 101 | dbi ->Ptr_tail = tail; 102 | 103 | if(rec != SQLITE_OK){ 104 | return NULL; 105 | } 106 | return dbi; 107 | } 108 | /* 109 | Another wrapper interface that is preserved 110 | for backwards compatibility. 111 | Use of this interface is not recommended. 112 | This was mainly used for testing within the 113 | library. 114 | */ 115 | void* sqlite3_get_table_idr(void* db, 116 | const char *sql){ 117 | 118 | DBinfo* dbi =(DBinfo*) db; 119 | char* err; 120 | 121 | Table* tbl = malloc(sizeof(Table)); 122 | tbl->database = dbi; 123 | int res = sqlite3_get_table(dbi->db_ptr,sql,&tbl->table_data,&tbl->num_row,&tbl->num_col,&err); 124 | int array_size = sizeof(&tbl->table_data); 125 | 126 | if( res != SQLITE_OK && err != NULL){ 127 | strncpy(dbi->buffer, err, sizeof(dbi->buffer)); 128 | sqlite3_free(err); 129 | return NULL; 130 | } 131 | tbl -> data_size = array_size; 132 | return tbl; 133 | } 134 | 135 | /* 136 | This function executes queries. 137 | This can be used after preparing a query 138 | In case of error or library misuse 139 | it returns 1. 140 | It also calls step in order to obtain 141 | the row and column number and stores them 142 | in the struct. The row number is needed 143 | later on in get_data_type function. 144 | */ 145 | int exec_db(void*p){ 146 | 147 | DBinfo* dbi =(DBinfo*) p; 148 | int rc, col, row_counter; 149 | 150 | const char* col_name; 151 | 152 | rc = sqlite3_step(dbi->ppStmt); 153 | 154 | if( rc == SQLITE_DONE){ 155 | return rc; 156 | } 157 | if(rc == SQLITE_ERROR && rc == SQLITE_MISUSE){ 158 | return 1; 159 | } 160 | row_counter =0; 161 | 162 | while (rc == SQLITE_ROW) { 163 | 164 | rc = sqlite3_step(dbi->ppStmt); 165 | row_counter++; 166 | } 167 | 168 | col = sqlite3_column_count(dbi->ppStmt); 169 | dbi->row_count = row_counter; 170 | dbi->col_count = col; 171 | return rc; 172 | } 173 | /* 174 | Returns row number from DB Struct 175 | 176 | */ 177 | int sqlite3_get_num_row_v2(void* p){ 178 | 179 | DBinfo* dbi =(DBinfo*) p; 180 | int row_number =dbi->row_count; 181 | return row_number; 182 | } 183 | 184 | /* 185 | Returns column number from DB Struct 186 | */ 187 | int sqlite3_get_num_col_v2(void* p){ 188 | 189 | DBinfo* dbi =(DBinfo*) p; 190 | int col_number =dbi-> col_count; 191 | return col_number; 192 | } 193 | 194 | /* 195 | Another way of obtaining row number 196 | Thought this function gets the value 197 | from Table struct. The value is stored 198 | in the struct after calling get_table. 199 | Using this version is not recommended 200 | unless used with get_table 201 | */ 202 | int sqlite3_get_num_row(void* p){ 203 | 204 | Table* tbl =(Table*) p; 205 | int row_number =tbl->num_row; 206 | return row_number; 207 | } 208 | 209 | /* 210 | Another way of obtaining column number 211 | Thought this function gets the value 212 | from Table struct. The value is stored 213 | in the struct after calling get_table. 214 | Using this version is not recommended 215 | unless used with get_table 216 | */ 217 | int sqlite3_get_num_col(void* p){ 218 | 219 | Table* tbl =(Table*) p; 220 | int col_number =tbl-> num_col; 221 | return col_number; 222 | } 223 | 224 | /* 225 | This routine returns the type of value 226 | and must be called after prepare and exec. 227 | Since exec steps through database to obtain 228 | row number, this function calls reset to 229 | set the pointer to its initial state 230 | and then calls sqlite3_column_type 231 | to get the type 232 | */ 233 | int sqlite3_get_data_type(void* p, int nRow, int nCol){ 234 | 235 | DBinfo* dbi =(DBinfo*) p; 236 | int rc, type, row_counter; 237 | const char* char_int; 238 | 239 | rc = sqlite3_reset(dbi->ppStmt); 240 | rc = sqlite3_step(dbi->ppStmt); 241 | row_counter =0; 242 | 243 | while (rc == SQLITE_ROW && row_counter < nRow) { 244 | 245 | rc = sqlite3_step(dbi->ppStmt); 246 | row_counter++; 247 | } 248 | type =sqlite3_column_type(dbi->ppStmt, nCol); 249 | return type; 250 | 251 | } 252 | /* 253 | Obtains the integer value in a given column 254 | */ 255 | 256 | int sqlite3_get_val_int(void* p, int nCol){ 257 | 258 | DBinfo* dbi =(DBinfo*) p; 259 | int val, col; 260 | val =sqlite3_column_int(dbi->ppStmt, nCol); 261 | return val; 262 | } 263 | 264 | /* 265 | Obtains the text value 266 | Need to allocate memory to store the string 267 | Use GC_malloc since Boehm garbage collector 268 | frees the resources . 269 | */ 270 | const unsigned char* sqlite3_get_val_text(void* p,int nCol){ 271 | 272 | 273 | DBinfo* dbi =(DBinfo*) p; 274 | int rc,i, val, counter; 275 | const unsigned char* text_val; 276 | array =(unsigned char *) malloc(1000*sizeof(char)); 277 | text_val =sqlite3_column_text(dbi->ppStmt, nCol); 278 | memcpy(array, text_val, strlen(text_val)); 279 | return array; 280 | 281 | } 282 | float sqlite3_get_float(void* p, int nCol){ 283 | 284 | DBinfo* dbi =(DBinfo*) p; 285 | double double_val; 286 | 287 | double_val =sqlite3_column_double(dbi->ppStmt, nCol); 288 | float float_val =(float)double_val; 289 | return float_val; 290 | 291 | } 292 | /* 293 | frees the pointer returned by get_table. 294 | */ 295 | 296 | void sqlite3_free_table_idr(void* db){ 297 | Table* tbl =(Table*) db; 298 | sqlite3_free_table(tbl->table_data); 299 | free(tbl); 300 | } 301 | int sqlite3_step_idr(void* db){ 302 | 303 | DBinfo* dbi =(DBinfo*) db; 304 | int rc =sqlite3_step(dbi->ppStmt); 305 | return rc; 306 | } 307 | /* 308 | Binds integer. This returns a pointer 309 | because of the implementation of BindMulti 310 | which binds multiple values 311 | */ 312 | void* sqlite3_bind_int_idr(void* p,int index, int val){ 313 | 314 | DBinfo* dbi =(DBinfo*) p; 315 | int rc; 316 | 317 | rc =sqlite3_bind_int(dbi->ppStmt,index,val); 318 | if(rc != SQLITE_OK){ 319 | return NULL; 320 | } 321 | 322 | return dbi; 323 | } 324 | 325 | void* sqlite3_bind_float_idr(void* p,int index, float val){ 326 | 327 | DBinfo* dbi =(DBinfo*) p; 328 | int rc; 329 | double res =(float)val; 330 | 331 | rc =sqlite3_bind_double(dbi->ppStmt,index,res); 332 | 333 | if(rc != SQLITE_OK){ 334 | return NULL; 335 | } 336 | return dbi; 337 | } 338 | 339 | void* sqlite3_bind_null_idr(void* p,int index){ 340 | 341 | DBinfo* dbi =(DBinfo*) p; 342 | int rc; 343 | rc =sqlite3_bind_null(dbi->ppStmt,index); 344 | if(rc != SQLITE_OK){ 345 | return NULL; 346 | } 347 | 348 | return dbi; 349 | } 350 | 351 | void* sqlite3_bind_text_idr(void* p,const char* text, int index,int length){ 352 | 353 | DBinfo* dbi =(DBinfo*) p; 354 | int rc; 355 | rc =sqlite3_bind_text(dbi->ppStmt,index,text,length,SQLITE_STATIC); 356 | if(rc != SQLITE_OK){ 357 | return NULL; 358 | } 359 | 360 | return dbi; 361 | } 362 | /* 363 | Used for testing column count function. 364 | This function prepares query and by passing 365 | select all, gets the count for column number 366 | Could be used for testing. Not recommended to 367 | be used with prepare and exec 368 | */ 369 | 370 | int sqlite3_column_count_idr(void* db, const char* tbl_name){ 371 | DBinfo* dbi =(DBinfo*) db; 372 | sqlite3_stmt* stmt; 373 | const char *tail; 374 | int rc; 375 | 376 | strcpy(sql_query_buffer, "select * from "); 377 | strcat(sql_query_buffer, tbl_name); 378 | 379 | rc = sqlite3_prepare_v2(dbi->db_ptr, sql_query_buffer, -1, &stmt, &tail); 380 | if(rc != SQLITE_OK){ 381 | fprintf(stderr, "SQL Prepare error"); 382 | return rc; 383 | } 384 | printf("Prepare successful %d\n", rc); 385 | 386 | rc =sqlite3_column_count(stmt); 387 | if(rc == 0){ 388 | fprintf(stderr, "SQL column count error\n"); 389 | return rc; 390 | } 391 | sqlite3_finalize(stmt); 392 | 393 | // rc = actual column count 394 | return rc; 395 | } 396 | 397 | int sqlite3_data_count_idr(void* db){ 398 | 399 | DBinfo* dbi =(DBinfo*) db; 400 | int rc = sqlite3_data_count(dbi->ppStmt); 401 | 402 | return rc; 403 | } 404 | /* 405 | Must be called after prepare to clean up 406 | the resources. 407 | */ 408 | int sqlite3_finalize_idr(void* db){ 409 | 410 | DBinfo* dbi=(DBinfo*) db; 411 | int rc =sqlite3_finalize(dbi->ppStmt); 412 | return rc; 413 | } 414 | 415 | int sqlite3_complete_idr(const char *sql){ 416 | 417 | int rc = sqlite3_complete(sql); 418 | return rc; 419 | } 420 | 421 | /* 422 | Resets a prepared statement pointer 423 | to its initial state 424 | */ 425 | int sqlite3_reset_idr(void* db){ 426 | 427 | DBinfo* dbi=(DBinfo*) db; 428 | int rc = sqlite3_reset(dbi-> ppStmt); 429 | return rc; 430 | 431 | } 432 | /* 433 | The following routines may be used to 434 | obtain column related information. 435 | */ 436 | const char *sqlite3_column_name_idr(void* db, int N){ 437 | 438 | DBinfo* dbi=(DBinfo*) db; 439 | const char *name = sqlite3_column_name(dbi->ppStmt, N); 440 | 441 | return name; 442 | } 443 | 444 | const char *sqlite3_column_decltype_idr(void* db,int n){ 445 | DBinfo* dbi=(DBinfo*) db; 446 | const char *dectype = sqlite3_column_decltype(dbi->ppStmt, n); 447 | 448 | return dectype; 449 | 450 | } 451 | int sqlite3_column_bytes_idr(void* db, int n){ 452 | 453 | DBinfo* dbi=(DBinfo*) db; 454 | int res = sqlite3_column_bytes(dbi->ppStmt, n); 455 | return res; 456 | 457 | 458 | } 459 | const void *sqlite3_column_blob_idr(void* db, int iCol){ 460 | DBinfo* dbi=(DBinfo*) db; 461 | const void* data =sqlite3_column_blob(dbi-> ppStmt, iCol); 462 | return data; 463 | } 464 | 465 | const unsigned char *sqlite3_column_text_idr(void* db, int iCol){ 466 | DBinfo* dbi=(DBinfo*) db; 467 | const unsigned char* col_text =sqlite3_column_text(dbi->ppStmt, iCol); 468 | return col_text; 469 | 470 | } 471 | 472 | int sqlite3_column_int_idr(void* db, int iCol){ 473 | DBinfo* dbi=(DBinfo*) db; 474 | int res =sqlite3_column_int(dbi-> ppStmt, iCol); 475 | return res; 476 | 477 | } 478 | /* 479 | Some back up functions 480 | */ 481 | 482 | void* sqlite3_backup_init_idr(void* pDest, 483 | const char *zDestName, 484 | void* pSource, 485 | const char *zSourceName 486 | ){ 487 | 488 | DBinfo* dbi=(DBinfo*) pDest; 489 | DBbackup* dbi2=(DBbackup*) pSource; 490 | 491 | void* res = sqlite3_backup_init(dbi->db_ptr,zDestName, 492 | dbi2->source_ptr,zSourceName); 493 | 494 | if(res == NULL){ 495 | printf("Error number in initializing backup : %d\n", sqlite3_errcode(dbi->db_ptr)); 496 | } 497 | 498 | dbi2->backup = res; 499 | return dbi2; 500 | 501 | 502 | } 503 | 504 | int sqlite3_backup_step_idr(void *backup, int nPage){ 505 | 506 | DBbackup* dbi=(DBbackup*) backup; 507 | int res = sqlite3_backup_step(dbi->backup, nPage); 508 | return res; 509 | 510 | 511 | } 512 | int sqlite3_backup_finish_idr(void *backup){ 513 | 514 | DBbackup* dbi=(DBbackup*) backup; 515 | int res = sqlite3_backup_finish(dbi->backup); 516 | return res; 517 | 518 | 519 | } 520 | 521 | int sqlite3_backup_remaining_idr(void *backup){ 522 | 523 | DBbackup* dbi=(DBbackup*) backup; 524 | int res = sqlite3_backup_remaining(dbi->backup); 525 | 526 | return res; 527 | } 528 | 529 | int sqlite3_backup_pagecount_idr(void *backup){ 530 | 531 | DBbackup* dbi=(DBbackup*) backup; 532 | int res =sqlite3_backup_pagecount(dbi-> backup); 533 | return res; 534 | 535 | } 536 | /* 537 | Get the length of string 538 | Need this in Idris since length will not 539 | work on Strings. 540 | */ 541 | int strLength(const char * str){ 542 | 543 | int length = strlen(str); 544 | return length; 545 | 546 | 547 | } 548 | 549 | 550 | -------------------------------------------------------------------------------- /src/sqlite3api.h: -------------------------------------------------------------------------------- 1 | /* 2 | * sqlite3api.h 3 | * 4 | * 5 | * Created by Melissa Farinaz MOZIFIAN on 22/06/2012. 6 | * Copyright 2012. All rights reserved. 7 | * 8 | */ 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | 16 | typedef struct { 17 | sqlite3 *db_ptr; // database pointer 18 | sqlite3_stmt *ppStmt; // statement pointer 19 | char buffer[1000]; // bufer to store errors returned by certain functions 20 | const char *Ptr_tail; 21 | sqlite3_value *value; 22 | int row_count; // row number store by exec function 23 | int col_count; 24 | 25 | } DBinfo; 26 | 27 | // struct used for backup functions 28 | typedef struct { 29 | sqlite3 *source_ptr; 30 | sqlite3_backup *backup; 31 | }DBbackup ; 32 | 33 | // Table struct used by get_table function 34 | // stores row and column 35 | // returned by get_table 36 | typedef struct { 37 | int num_row; 38 | int num_col; 39 | char** table_data; 40 | int data_size; 41 | int* data_type; 42 | DBinfo* database; 43 | }Table; 44 | 45 | 46 | void* sqlite3_open_idr(const char *filename); 47 | 48 | int exec_db(void*p); 49 | 50 | int sqlite3_close_idr(void* db); 51 | 52 | int sqlite3_exec_idr(void*, const char *sql); 53 | 54 | char* sqlite3_get_error(void* db); 55 | 56 | const unsigned char* sqlite3_get_val_text(void* p,int nCol); 57 | 58 | void* sqlite3_get_table_idr(void* db, const char *sql); 59 | 60 | void sqlite3_free_table_idr(void* db); 61 | 62 | int sqlite3_get_num_col(void* p); 63 | 64 | int sqlite3_get_num_row(void* p); 65 | 66 | int sqlite3_get_num_row_v2(void* p); 67 | 68 | int sqlite3_get_num_col_v2(void* p); 69 | 70 | int sqlite3_get_data_type(void* p, int nRow, int nCol); 71 | 72 | int sqlite3_get_val_int(void* p,int nCo); 73 | 74 | float sqlite3_get_float(void* p, int nCol); 75 | 76 | void* sqlite3_prepare_idr( 77 | void *db, /* Database handle */ 78 | const char *zSql /* SQL statement, UTF-8 encoded */ 79 | ); 80 | 81 | int sqlite3_step_idr(void* stmt); 82 | 83 | void* sqlite3_bind_float_idr(void* p,int index, float val); 84 | 85 | void* sqlite3_bind_int_idr(void* p,int index , int val); 86 | 87 | void* sqlite3_bind_null_idr(void* p,int index); 88 | 89 | void* sqlite3_bind_text_idr(void* p,const char* text, int index,int length); 90 | 91 | int sqlite3_column_count_idr(void* stmt, const char* tbl_name); 92 | 93 | int sqlite3_data_count_idr(void* stmt); 94 | 95 | int sqlite3_reset_idr(void* stmt); 96 | 97 | int sqlite3_finalize_idr(void* stmt); 98 | 99 | int sqlite3_complete_idr(const char *sql); 100 | 101 | const char *sqlite3_column_decltype_idr(void* stmt,int n); 102 | 103 | const char *sqlite3_column_name_idr(void* stmt, int N); 104 | 105 | int sqlite3_column_bytes_idr(void* stmt, int n); 106 | 107 | int sqlite3_column_bytes_idr(void* stmt, int n); 108 | 109 | const void *sqlite3_column_blob_idr(void* stmt, int iCol); 110 | 111 | const unsigned char *sqlite3_column_text_idr(void* stmt, int iCol); 112 | 113 | int sqlite3_column_int_idr(void* stmt, int iCol); 114 | 115 | 116 | void* sqlite3_backup_init_idr(void* pDestm, 117 | const char *zDestName, 118 | void* pSource, 119 | const char *zSourceName 120 | ); 121 | 122 | int sqlite3_backup_finish_idr(void *backup); 123 | 124 | int sqlite3_backup_step_idr(void *backup, int nPage); 125 | 126 | int sqlite3_backup_remaining_idr(void *backup); 127 | 128 | int sqlite3_backup_pagecount_idr(void *backup); 129 | 130 | int strLength(const char * str); 131 | --------------------------------------------------------------------------------