├── .gitignore ├── Figment.Tests ├── Main.fs ├── Prelude.fs ├── packages.config ├── ExtensionsTests.fs ├── RoutingTests.fs ├── ResultTests.fs └── Figment.Tests.fsproj ├── .nuget ├── packages.config └── BuildMagic.targets ├── packages └── repositories.config ├── Figment ├── packages.config ├── web.config ├── Server.fs ├── Filters.fs ├── RoutingConstraints.fs ├── RouteHandler.fs ├── Binding.fs ├── Testing.fs ├── Figment.fsproj ├── Result.fs ├── Routing.fs ├── Extensions.fs └── Helpers.fs └── Figment.sln /.gitignore: -------------------------------------------------------------------------------- 1 | *.suo 2 | *.user 3 | */bin/* 4 | */obj/* 5 | _ReSharper.* 6 | packages/* -------------------------------------------------------------------------------- /Figment.Tests/Main.fs: -------------------------------------------------------------------------------- 1 | open Fuchu 2 | 3 | [] 4 | let main args = defaultMainThisAssembly args -------------------------------------------------------------------------------- /.nuget/packages.config: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | -------------------------------------------------------------------------------- /packages/repositories.config: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -------------------------------------------------------------------------------- /Figment.Tests/Prelude.fs: -------------------------------------------------------------------------------- 1 | namespace Figment.Tests 2 | 3 | [] 4 | module Assertions = 5 | open System 6 | open Fuchu 7 | 8 | type Assert with 9 | static member inline Cast v : 'b = 10 | try 11 | unbox v 12 | with _ -> failtestf "Expected type: %A\nActual type: %A" typeof<'b> (v.GetType()) 13 | 14 | -------------------------------------------------------------------------------- /Figment/packages.config: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /Figment.Tests/packages.config: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /Figment.Tests/ExtensionsTests.fs: -------------------------------------------------------------------------------- 1 | module Figment.Tests.Extensions 2 | 3 | open System 4 | open Microsoft.FSharp.Reflection 5 | open Figment.Extensions 6 | open Fuchu 7 | 8 | [] 9 | let tests = 10 | testList "Extensions" [ 11 | testCase "InvokeFunction" <| fun _ -> 12 | let f a b c = a + b + c 13 | let r = FSharpValue.InvokeFunction f [1;2;3] 14 | Assert.NotNull("InvokeFunction result", r) 15 | let r : int = Assert.Cast r 16 | Assert.Equal("InvokeFunction result", 6, r) 17 | 18 | testCase "GetFlattenedFunctionElements throws on non-function" <| fun _ -> 19 | let a = 2 20 | let r () = FSharpType.GetFlattenedFunctionElements (a.GetType()) 21 | Assert.Raise("", typeof, r >> ignore) 22 | 23 | testCase "GetFlattenedFunctionElements on (unit -> int)" <| fun _ -> 24 | let f() = 2 25 | let t = FSharpType.GetFlattenedFunctionElements(f.GetType()) 26 | Assert.Equal("elements", [typeof; typeof], t) 27 | 28 | testCase "GetFlattenedFunctionElements on (int -> float -> string)" <| fun _ -> 29 | let f (i: int) (j: float) = "bla" 30 | let t = FSharpType.GetFlattenedFunctionElements(f.GetType()) 31 | Assert.Equal("", [typeof; typeof; typeof], t) 32 | ] 33 | -------------------------------------------------------------------------------- /Figment.Tests/RoutingTests.fs: -------------------------------------------------------------------------------- 1 | module Figment.Tests.Routing 2 | 3 | open System 4 | open System.Web 5 | open System.Web.Routing 6 | open Figment.Routing 7 | open Figment.RoutingConstraints 8 | open Fuchu 9 | 10 | [] 11 | let tests = 12 | testList "Routing tests" [ 13 | testList "stripFormatting" [ 14 | testCase "one int" <| fun _ -> 15 | let url, parameters = stripFormatting "/question/{id:%d}/{title}" 16 | Assert.Equal("url", "/question/{id}/{title}", url) 17 | Assert.Equal("parameter length", 1, parameters.Length) 18 | Assert.Equal("first parameter", "id", parameters.[0]) 19 | 20 | testCase "one int and one string" <| fun _ -> 21 | let url, parameters = stripFormatting "/question/{id:%d}/{title:%s}" 22 | Assert.Equal("url", "/question/{id}/{title}", url) 23 | Assert.Equal("parameter length", 2, parameters.Length) 24 | Assert.Equal("first parameter", "id", parameters.[0]) 25 | Assert.Equal("2nd parameter", "title", parameters.[1]) 26 | ] 27 | 28 | testCase "ifUrlMatches" <| fun _ -> 29 | let ctx = {new HttpContextBase() with 30 | override x.Request = {new HttpRequestBase() with 31 | override x.Url = Uri("http://localhost/something")}} 32 | let route = RouteData() 33 | let c = ctx, route 34 | if not (ifUrlMatches "^/some" c) 35 | then failtest "Should have matched ^/some" 36 | if ifUrlMatches "^/some$" c 37 | then failtest "Should not have matched ^/some$" 38 | ] -------------------------------------------------------------------------------- /Figment.Tests/ResultTests.fs: -------------------------------------------------------------------------------- 1 | module Figment.Tests.Result 2 | 3 | open System 4 | open System.Text 5 | open System.Web 6 | open System.Web.Routing 7 | open System.Web.Mvc 8 | open Figment.Result 9 | open Figment.Testing 10 | open Fuchu 11 | 12 | [] 13 | let tests = 14 | testList "Results" [ 15 | testCase "status result" <| fun _ -> 16 | let ctx = 17 | let statusCode = ref 0 18 | buildResponse 19 | { new HttpResponseBase() with 20 | member x.StatusCode 21 | with get() = !statusCode 22 | and set v = statusCode := v } 23 | let ctx = buildCtx ctx 24 | status 200 ctx 25 | Assert.Equal("status code", 200, ctx.HttpContext.Response.StatusCode) 26 | 27 | testCase "JSONP content type is application/javascript" <| fun _ -> 28 | let callback (ctx: ControllerContext) = "callback" 29 | let sb = StringBuilder() 30 | let ctx = 31 | let contentType = ref "" 32 | buildResponse 33 | { new HttpResponseBase() with 34 | member x.ContentType 35 | with get() = !contentType 36 | and set v = contentType := v 37 | member x.Write(s: string) = 38 | sb.Append s |> ignore } 39 | let ctx = buildCtx ctx 40 | jsonp callback "something" ctx 41 | Assert.Equal("response", "callback(\"something\")", sb.ToString()) 42 | Assert.Equal("content type", "application/javascript", ctx.HttpContext.Response.ContentType) 43 | ] 44 | -------------------------------------------------------------------------------- /Figment/web.config: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /Figment/Server.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | open System 4 | open System.IO 5 | open System.Diagnostics 6 | open System.Reflection 7 | 8 | type Server = 9 | static member private startup(path: string option, port: string option, vpath: string option) = 10 | // code adapted from FSharp.PowerPack's AspNetTester 11 | let progfile = 12 | let prg = Environment.GetFolderPath(Environment.SpecialFolder.ProgramFiles) 13 | if Environment.Is64BitProcess 14 | then prg + " (x86)" 15 | else prg 16 | 17 | let webserver = Path.Combine(progfile, @"Common Files\microsoft shared\DevServer\10.0\WebDev.WebServer40.EXE") 18 | if not (File.Exists webserver) 19 | then failwith "No ASP.NET dev web server found." 20 | printfn "%s" webserver 21 | 22 | let webSitePath = 23 | match path with 24 | | None -> Directory.GetParent(Directory.GetCurrentDirectory()).FullName 25 | | Some a -> a.Substring 5 26 | printfn "path: %s" webSitePath 27 | 28 | let port = 29 | match port with 30 | | None -> Random().Next(10000, 65535) 31 | | Some a -> Convert.ToInt32 (a.Substring 5) 32 | printfn "port: %d" port 33 | 34 | let vpath = 35 | match vpath with 36 | | None -> "" 37 | | Some a -> a.Substring 6 38 | let pathArg = sprintf "/path:%s" webSitePath 39 | let portArg = sprintf "/port:%d" port 40 | 41 | let asm = Assembly.LoadFile webserver 42 | let run (args: string[]) = asm.EntryPoint.Invoke(null, [| args |]) :?> int 43 | 44 | Process.Start (sprintf "http://localhost:%d%s" port vpath) |> ignore 45 | 46 | (* 47 | AppDomain.CurrentDomain.GetAssemblies() 48 | |> Seq.map (fun a -> a.FullName) 49 | |> Seq.iter (printfn "%s") 50 | *) 51 | 52 | run [| pathArg; portArg |] 53 | 54 | static member start(?path: string, ?port: string, ?vpath: string) = 55 | Server.startup(path, port, vpath) 56 | 57 | static member start(args: string[]) = 58 | let getArg arg = args |> Seq.tryFind (fun a -> a.ToUpperInvariant().StartsWith arg) 59 | Server.startup(getArg "PATH:", getArg "PORT:", getArg "VPATH:") 60 | -------------------------------------------------------------------------------- /Figment/Filters.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | open System.Linq 4 | open System.Security.Principal 5 | open System.Web.Routing 6 | open System.Web.Mvc 7 | open System.Web.UI 8 | open Figment.Result 9 | open Figment.Helpers 10 | 11 | module private Internals = 12 | 13 | let internal irequireHttps (action: ControllerContext -> 'a) redirect (ctx: ControllerContext): 'a = 14 | if ctx.HttpContext.Request.IsSecureConnection 15 | then action ctx 16 | else 17 | let request = ctx.HttpContext.Request 18 | if request.HttpMethod <>. "GET" 19 | then failwithf "HTTPS required for %s" request.RawUrl 20 | redirect (sprintf "https://%s%s" request.Url.Host request.RawUrl) ctx 21 | 22 | module Filters = 23 | 24 | open FSharpx 25 | open FSharpx.Reader 26 | 27 | type Filter = FAction -> FAction 28 | 29 | let hasAuthorization (allowedUsers: string list) (allowedRoles: string list) (user: IPrincipal) = 30 | if not user.Identity.IsAuthenticated 31 | then false 32 | else 33 | let userMatch = allowedUsers.Length = 0 || (Seq.exists ((=) user.Identity.Name) allowedUsers) 34 | let roleMatch = allowedRoles.Length = 0 || (Seq.exists user.IsInRole allowedRoles) 35 | userMatch && roleMatch 36 | 37 | let authorize (allowedUsers: string list) (allowedRoles: string list) (action: FAction) : FAction = 38 | fun ctx -> 39 | let user = ctx.HttpContext.User 40 | let authorized = user |> hasAuthorization allowedUsers allowedRoles 41 | if authorized 42 | then action ctx 43 | else unauthorized ctx 44 | 45 | let requireHttps (action: FAction) : FAction = 46 | Internals.irequireHttps action redirect 47 | 48 | let internal getCookieValueOrNull name ctx = 49 | match getHttpCookie name ctx with 50 | | None -> null 51 | | Some c -> c.Value 52 | 53 | let flash (a: FAction): FAction = 54 | getCookieValueOrNull flashCookieKey 55 | |> Reader.map base64decode 56 | >>= setInContext flashContextKey 57 | >>. removeHttpCookie flashCookieKey 58 | >>. a 59 | 60 | let apply (filter: Filter) (actions: seq) = 61 | actions |> Seq.map (fun (k,v) -> (k, filter v)) 62 | 63 | module AsyncFilters = 64 | let requireHttps (action: FAsyncAction) : FAsyncAction = 65 | fun ctx -> 66 | Internals.irequireHttps action (fun s ctx -> async.Return (redirect s ctx)) <| ctx 67 | 68 | // TODO implement other filters for async actions 69 | -------------------------------------------------------------------------------- /Figment/RoutingConstraints.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | [] 4 | module RoutingConstraints = 5 | 6 | open System 7 | open System.Text.RegularExpressions 8 | open System.Web 9 | open System.Web.Routing 10 | open Helpers 11 | 12 | type RouteConstraint = HttpContextBase * RouteData -> bool 13 | 14 | (* operators *) 15 | let allOf (constraints: RouteConstraint list) (ctx: HttpContextBase, route: RouteData) = 16 | Seq.forall (fun c -> c(ctx,route)) constraints 17 | 18 | let anyOf (constraints: RouteConstraint list) (ctx: HttpContextBase, route: RouteData) = 19 | Seq.exists (fun c -> c(ctx,route)) constraints 20 | 21 | let (||.) (x: RouteConstraint) (y: RouteConstraint) = anyOf [x;y] 22 | 23 | let (&&.) (x: RouteConstraint) (y: RouteConstraint) = allOf [x;y] 24 | 25 | let (!.) (x: RouteConstraint) (ctx: HttpContextBase, route: RouteData) = 26 | not (x(ctx, route)) 27 | 28 | (* constraints *) 29 | let any (ctx: HttpContextBase, route: RouteData) = true 30 | 31 | let ifPathIs url = 32 | fun (ctx: HttpContextBase, route: RouteData) -> 33 | ctx.Request.Url.AbsolutePath = url 34 | 35 | let ifInsensitivePathIs url = 36 | fun (ctx: HttpContextBase, route: RouteData) -> 37 | ctx.Request.Url.AbsolutePath =. url 38 | 39 | let ifPathIsf fmt = Printf.ksprintf ifPathIs fmt 40 | 41 | let ifInsensitivePathIsf fmt = Printf.ksprintf ifInsensitivePathIs fmt 42 | 43 | let ifUrlMatches (rx: string) = 44 | if rx = null 45 | then invalidArg "rx" "regex null" 46 | let rxx = Regex(rx) 47 | fun (ctx: HttpContextBase, route: RouteData) -> 48 | rxx.IsMatch ctx.Request.Url.AbsolutePath 49 | 50 | let ifMethodIs httpMethod = 51 | if httpMethod = null 52 | then invalidArg "httpMethod" "httpMethod null" 53 | fun (ctx: HttpContextBase, route: RouteData) -> 54 | ctx.Request.HttpMethod =. httpMethod 55 | 56 | let ifMethodIsGet x = ifMethodIs "GET" x 57 | let ifMethodIsPost x = ifMethodIs "POST" x 58 | let ifMethodIsHead x = ifMethodIs "HEAD" x 59 | let ifMethodIsPut x = ifMethodIs "PUT" x 60 | let ifMethodIsOptions x = ifMethodIs "OPTIONS" x 61 | 62 | let ifUserAgentMatches (rx: string) = 63 | if rx = null 64 | then invalidArg "rx" "regex null" 65 | let rxx = Regex(rx) 66 | fun (ctx: HttpContextBase, route: RouteData) -> 67 | rxx.IsMatch ctx.Request.UserAgent 68 | 69 | let ifIsAjax (ctx: HttpContextBase, route: RouteData) = 70 | let requestedWith = ctx.Request.Headers.["X-Requested-With"] 71 | requestedWith <> null && requestedWith =. "xmlhttprequest" -------------------------------------------------------------------------------- /Figment/RouteHandler.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | open System 4 | open System.Web 5 | open System.Web.Mvc 6 | open System.Web.Mvc.Async 7 | open System.Web.Routing 8 | open Figment.Helpers 9 | 10 | open System.Diagnostics 11 | open Extensions 12 | 13 | type IHttpHandlerBase = 14 | abstract ProcessRequest: HttpContextBase -> unit 15 | 16 | type IControllerProvider = 17 | abstract CreateController: unit -> IController 18 | 19 | type FigmentHandler(context: RequestContext, action: FAction) = 20 | let proc (ctx: HttpContextBase) = 21 | let controller = buildControllerFromAction action 22 | ctx.Request.DisableValidation() |> ignore 23 | controller.ValidateRequest <- false 24 | (controller :> IController).Execute context 25 | 26 | interface IControllerProvider with 27 | member this.CreateController() = upcast buildControllerFromAction action 28 | 29 | interface IHttpHandlerBase with 30 | member this.ProcessRequest(ctx: HttpContextBase) = proc ctx 31 | 32 | interface System.Web.SessionState.IRequiresSessionState 33 | interface IHttpHandler with 34 | member this.IsReusable = false 35 | member this.ProcessRequest ctx = HttpContextWrapper(ctx) |> proc 36 | 37 | type FigmentAsyncHandler(context: RequestContext, action: FAsyncAction) = 38 | let proc (ctx: HttpContextBase) = 39 | let controller = buildControllerFromAsyncAction action 40 | ctx.Request.DisableValidation() |> ignore 41 | controller.ValidateRequest <- false 42 | (controller :> IController).Execute context 43 | 44 | interface IControllerProvider with 45 | member this.CreateController() = upcast buildControllerFromAsyncAction action 46 | 47 | interface IHttpHandlerBase with 48 | member this.ProcessRequest(ctx: HttpContextBase) = proc ctx 49 | 50 | interface System.Web.SessionState.IRequiresSessionState 51 | interface IHttpAsyncHandler with 52 | member this.IsReusable = false 53 | member this.ProcessRequest ctx = HttpContextWrapper(ctx) |> proc 54 | member this.BeginProcessRequest(ctx, cb, state) = 55 | Debug.WriteLine "BeginProcessRequest" 56 | let controller = buildControllerFromAsyncAction action :> IAsyncController 57 | controller.BeginExecute(context, cb, state) 58 | 59 | member this.EndProcessRequest r = 60 | Debug.WriteLine "EndProcessRequest" 61 | 62 | module RouteHandlerHelpers = 63 | let inline buildActionRouteHandler (action: FAction) = 64 | buildRouteHandler (fun ctx -> upcast FigmentHandler(ctx, action)) 65 | 66 | let inline buildAsyncActionRouteHandler (action: FAsyncAction) = 67 | buildRouteHandler (fun ctx -> upcast FigmentAsyncHandler(ctx, action)) 68 | -------------------------------------------------------------------------------- /Figment.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 11.00 3 | # Visual Studio 2010 4 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Figment.Tests", "Figment.Tests\Figment.Tests.fsproj", "{D5A17CEF-E6A6-459D-961F-588A1A1DCD49}" 5 | EndProject 6 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Figment", "Figment\Figment.fsproj", "{A080B979-6E39-44C4-AC1A-4850E32C355A}" 7 | EndProject 8 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".nuget", ".nuget", "{C36EB5AB-6A5E-4950-924D-E694E16035C6}" 9 | ProjectSection(SolutionItems) = preProject 10 | .nuget\packages.config = .nuget\packages.config 11 | EndProjectSection 12 | EndProject 13 | Global 14 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 15 | Debug|Any CPU = Debug|Any CPU 16 | Debug|Mixed Platforms = Debug|Mixed Platforms 17 | Debug|x86 = Debug|x86 18 | Release|Any CPU = Release|Any CPU 19 | Release|Mixed Platforms = Release|Mixed Platforms 20 | Release|x86 = Release|x86 21 | EndGlobalSection 22 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 23 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 24 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Debug|Any CPU.Build.0 = Debug|Any CPU 25 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Debug|Mixed Platforms.ActiveCfg = Debug|Any CPU 26 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Debug|Mixed Platforms.Build.0 = Debug|Any CPU 27 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Debug|x86.ActiveCfg = Debug|Any CPU 28 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Release|Any CPU.ActiveCfg = Release|Any CPU 29 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Release|Any CPU.Build.0 = Release|Any CPU 30 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Release|Mixed Platforms.ActiveCfg = Release|Any CPU 31 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Release|Mixed Platforms.Build.0 = Release|Any CPU 32 | {A080B979-6E39-44C4-AC1A-4850E32C355A}.Release|x86.ActiveCfg = Release|Any CPU 33 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 34 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Debug|Any CPU.Build.0 = Debug|Any CPU 35 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Debug|Mixed Platforms.ActiveCfg = Debug|Any CPU 36 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Debug|Mixed Platforms.Build.0 = Debug|Any CPU 37 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Debug|x86.ActiveCfg = Debug|Any CPU 38 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Release|Any CPU.ActiveCfg = Release|Any CPU 39 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Release|Any CPU.Build.0 = Release|Any CPU 40 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Release|Mixed Platforms.ActiveCfg = Release|Any CPU 41 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Release|Mixed Platforms.Build.0 = Release|Any CPU 42 | {D5A17CEF-E6A6-459D-961F-588A1A1DCD49}.Release|x86.ActiveCfg = Release|Any CPU 43 | EndGlobalSection 44 | GlobalSection(SolutionProperties) = preSolution 45 | HideSolutionNode = FALSE 46 | EndGlobalSection 47 | EndGlobal 48 | -------------------------------------------------------------------------------- /.nuget/BuildMagic.targets: -------------------------------------------------------------------------------- 1 | 2 | 3 | 22 | 23 | 25 | 26 | 27 | 1.8.40000 28 | http://nuget.org/api/v1/package/NuGet.CommandLine/$(BuildMagicNuGetVersion) 29 | $(MSBuildThisFileDirectory)/bin 30 | $(BuildMagicNuGetFolder)/NuGet.exe 31 | $(MSBuildProjectDirectory)/packages.config 32 | 33 | $(MSBuildThisFileDirectory)/../packages 34 | BuildMagicRestore;$(BuildDependsOn) 35 | 36 | 37 | 38 | 39 |

40 | 41 | 42 | 43 |


44 |         
52 |

53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 |


65 |          x.Uri.ToString() == PathInZipFile);
69 |             using (var stream = part.GetStream(FileMode.Open))
70 |             {
71 |               Directory.CreateDirectory(Path.GetDirectoryName(DestinationFile));
72 |               using (var output = File.Open(DestinationFile, FileMode.Create))
73 |               {
74 |                 stream.CopyTo(output);
75 |               }
76 |             }
77 |             return true;
78 |           }
79 |         ]]>
80 |

81 | 82 | 83 | 84 | 85 | 86 | $(BuildMagicNuGetLocation).zip 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /Figment/Binding.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | module Binding = 4 | 5 | open System 6 | open System.Web.Mvc 7 | open System.Globalization 8 | open System.Collections.Specialized 9 | open System.Text 10 | open Microsoft.FSharp.Quotations 11 | open Microsoft.FSharp.Quotations.Patterns 12 | open Printf 13 | 14 | let ignoreContext (action: unit -> 'a) (ctx: ControllerContext) = 15 | action() 16 | 17 | /// handles a binding error by throwing 18 | let bindErrorThrow (parameter: string) (modelType: Type) (provider: IValueProvider) = 19 | let sb = StringBuilder() 20 | bprintf sb "Binding failed for model name '%s'\n" parameter 21 | bprintf sb "Model type: '%s'\n" modelType.FullName 22 | let rawValue = provider.GetValue(parameter).RawValue 23 | bprintf sb "Actual value: '%A'\n" rawValue 24 | let rawValueType = 25 | if rawValue = null 26 | then "NULL" 27 | else rawValue.GetType().FullName 28 | bprintf sb "Actual type: '%s'\n" rawValueType 29 | bprintf sb "Value provider: '%s'\n" (provider.GetType().Name) 30 | failwith (sb.ToString()) 31 | 32 | /// handles a binding error by returning a default value 33 | let bindErrorDefault defaultValue (parameter: string) (modelType: Type) (provider: IValueProvider) = 34 | defaultValue 35 | 36 | let bindErrorDefaultOfType (parameter: string) (modelType: Type) (provider: IValueProvider) = 37 | Helpers.defaultValueOf modelType 38 | 39 | let bindSingleParameterNG (ty: Type) (parameter: string) (valueProvider: IValueProvider) (ctx: ControllerContext) = 40 | let binder = ModelBinders.Binders.GetBinder ty 41 | let bindingContext = ModelBindingContext( 42 | ModelName = parameter, 43 | ModelState = ctx.Controller.ViewData.ModelState, 44 | ModelMetadata = ModelMetadataProviders.Current.GetMetadataForType(null, ty), 45 | ValueProvider = valueProvider) 46 | let r = binder.BindModel(ctx, bindingContext) 47 | if not bindingContext.ModelState.IsValid 48 | then bindErrorThrow parameter ty ctx.Controller.ValueProvider 49 | else r 50 | 51 | let bindSingleParameter<'a> (parameter: string) (valueProvider: IValueProvider) (bindError: string -> Type -> IValueProvider -> 'a) (ctx: ControllerContext) = 52 | let binder = ModelBinders.Binders.GetBinder typeof<'a> 53 | let bindingContext = ModelBindingContext( 54 | ModelName = parameter, 55 | ModelState = ctx.Controller.ViewData.ModelState, 56 | ModelMetadata = ModelMetadataProviders.Current.GetMetadataForType(null, typeof<'a>), 57 | ValueProvider = valueProvider) 58 | let r = binder.BindModel(ctx, bindingContext) 59 | if not bindingContext.ModelState.IsValid 60 | then bindError parameter typeof<'a> ctx.Controller.ValueProvider 61 | else r :?> 'a 62 | 63 | let bindOne<'a> (parameter: string) (ctx: ControllerContext) = 64 | bindSingleParameter<'a> parameter ctx.Controller.ValueProvider bindErrorThrow ctx 65 | 66 | let bind (parameter: string) (f: 'a -> 'b) (ctx: ControllerContext) = 67 | let r = bindOne<'a> parameter ctx 68 | f r 69 | 70 | let bind2 (parameter1: string) (parameter2: string) (f: 'a -> 'b -> 'c) (ctx: ControllerContext) = 71 | let v1 = bindOne<'a> parameter1 ctx 72 | let v2 = bindOne<'b> parameter2 ctx 73 | f v1 v2 74 | 75 | /// bind2 implemented on top of bind (instead of bindOne) 76 | let bind2alt (parameter1: string) (parameter2: string) (f: 'a -> 'b -> 'c) (ctx: ControllerContext) = 77 | let b1 = bind parameter1 f 78 | let b1 b a = b1 a b 79 | let b1 = bind parameter2 b1 80 | let b1 b a = b1 a b 81 | b1 ctx ctx 82 | 83 | let contentResult (action: 'a -> string) a = 84 | action a |> Result.content 85 | 86 | let bindForm (action: NameValueCollection -> 'a) (ctx: ControllerContext) = 87 | action ctx.HttpContext.Request.Form 88 | 89 | let bindQuerystring (action: NameValueCollection -> 'a) (ctx: ControllerContext) = 90 | action ctx.HttpContext.Request.QueryString 91 | 92 | let buildModelBinder f = 93 | { new IModelBinder with 94 | member this.BindModel(controllerContext, bindingContext) = f controllerContext bindingContext } 95 | 96 | type ModelBinderDictionary with 97 | member this.Add(t: Type, f: ControllerContext -> ModelBindingContext -> obj) = 98 | this.Add(t, buildModelBinder f) 99 | -------------------------------------------------------------------------------- /Figment/Testing.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | open System 4 | open System.Collections 5 | open System.Collections.Generic 6 | open System.Collections.Specialized 7 | open System.Diagnostics 8 | open System.Web 9 | open System.Web.Mvc 10 | open System.Web.Routing 11 | open FSharpx 12 | 13 | module Testing = 14 | let dummyController = { new ControllerBase() with member x.ExecuteCore() = () } 15 | 16 | let buildCtx ctx = 17 | let req = RequestContext(ctx, RouteData()) 18 | ControllerContext(req, dummyController) 19 | 20 | let buildRequest verb path = 21 | { new HttpContextBase() with 22 | override x.Request = 23 | { new HttpRequestBase() with 24 | override y.ValidateInput() = () 25 | override y.HttpMethod = verb 26 | override y.RawUrl = path 27 | override y.PathInfo = path 28 | override y.AppRelativeCurrentExecutionFilePath = "~/" 29 | override y.Path = path 30 | override y.Url = Uri("http://localhost" + path) }} 31 | 32 | let buildResponse resp = 33 | { new HttpContextBase() with 34 | override x.Response = resp } 35 | 36 | let withRequest request ctx = 37 | { new DelegatingHttpContextBase(ctx) with 38 | override x.Request = request } :> HttpContextBase 39 | 40 | let withResponse response ctx = 41 | { new DelegatingHttpContextBase(ctx) with 42 | override x.Response = response } :> HttpContextBase 43 | 44 | let withForm form ctx = 45 | ctx 46 | |> withRequest 47 | { new DelegatingHttpRequestBase(ctx.Request) with 48 | override y.Form = form } 49 | 50 | let fileCollection (files: seq) = 51 | { new HttpFileCollectionBase() with 52 | override x.AllKeys = files |> Seq.map fst |> Seq.toArray 53 | override x.Item 54 | with get (k: string) = 55 | files 56 | |> Seq.tryFind (fst >> (=)k) 57 | |> Option.map snd 58 | |> Option.getOrDefault } 59 | 60 | let withFiles files ctx = 61 | ctx 62 | |> withRequest 63 | { new DelegatingHttpRequestBase(ctx.Request) with 64 | override y.Files = fileCollection files } 65 | 66 | let withQueryString querystring ctx = 67 | ctx 68 | |> withRequest 69 | { new DelegatingHttpRequestBase(ctx.Request) with 70 | override y.QueryString = querystring } 71 | 72 | let tryGetController verb path = 73 | let ctx = buildRequest verb path 74 | RouteTable.Routes.tryGetRouteData ctx 75 | |> Option.map (fun route -> 76 | let rctx = RequestContext(ctx, route) 77 | let handler : Figment.IControllerProvider = unbox <| route.RouteHandler.GetHttpHandler(rctx) 78 | route, handler.CreateController()) 79 | 80 | let getController verb path = 81 | tryGetController verb path 82 | |> Option.getOrElseF (fun () -> failwithf "No controller found for %s %s" verb path) 83 | 84 | let stubSession ctx = 85 | let session = OrderedDictionary() 86 | let timeout = ref 0 87 | { new DelegatingHttpContextBase(ctx) with 88 | override x.Session = 89 | { new HttpSessionStateBase() with 90 | override y.Abandon() = 91 | session.Clear() 92 | override y.Clear() = 93 | session.Clear() 94 | override y.CopyTo(array, index) = 95 | (session :> ICollection).CopyTo(array, index) 96 | override y.GetEnumerator() = 97 | session.Keys.GetEnumerator() 98 | override y.Item 99 | with get (k:string) = session.[k] 100 | and set (k: string) (v:obj) = session.[k] <- v 101 | override y.Item 102 | with get (k: int) = session.[k] 103 | and set (k: int) (v:obj) = session.[k] <- v 104 | override y.Remove k = 105 | session.Remove k 106 | override y.RemoveAll() = session.Clear() 107 | override y.RemoveAt i = session.RemoveAt i 108 | override y.Timeout 109 | with get() = !timeout 110 | and set v = timeout := v 111 | } } :> HttpContextBase 112 | 113 | let withRoute route (ctx: ControllerContext) = 114 | ControllerContext(ctx.HttpContext, route, ctx.Controller) -------------------------------------------------------------------------------- /Figment/Figment.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Debug 5 | AnyCPU 6 | 8.0.30703 7 | 2.0 8 | {a080b979-6e39-44c4-ac1a-4850e32c355a} 9 | Library 10 | Figment 11 | Figment 12 | v4.0 13 | Figment 14 | 15 | 16 | true 17 | full 18 | false 19 | false 20 | bin\Debug\ 21 | DEBUG;TRACE 22 | 3 23 | bin\Debug\Figment.XML 24 | 25 | 26 | pdbonly 27 | true 28 | true 29 | bin\Release\ 30 | TRACE 31 | 3 32 | bin\Release\Figment.XML 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | ..\packages\FSharpx.Core.1.6.4\lib\40\Fsharpx.Core.dll 54 | True 55 | 56 | 57 | ..\packages\Microsoft.Web.Infrastructure.1.0.0.0\lib\net40\Microsoft.Web.Infrastructure.dll 58 | True 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | ..\packages\Microsoft.AspNet.WebPages.1.0.20105.408\lib\net40\System.Web.Helpers.dll 70 | True 71 | 72 | 73 | ..\packages\Microsoft.AspNet.Mvc.3.0.20105.1\lib\net40\System.Web.Mvc.dll 74 | True 75 | 76 | 77 | ..\packages\Microsoft.AspNet.Razor.1.0.20105.408\lib\net40\System.Web.Razor.dll 78 | True 79 | 80 | 81 | 82 | ..\packages\Microsoft.AspNet.WebPages.1.0.20105.408\lib\net40\System.Web.WebPages.dll 83 | True 84 | 85 | 86 | ..\packages\Microsoft.AspNet.WebPages.1.0.20105.408\lib\net40\System.Web.WebPages.Deployment.dll 87 | True 88 | 89 | 90 | ..\packages\Microsoft.AspNet.WebPages.1.0.20105.408\lib\net40\System.Web.WebPages.Razor.dll 91 | True 92 | 93 | 94 | 95 | 102 | -------------------------------------------------------------------------------- /Figment.Tests/Figment.Tests.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Debug 5 | AnyCPU 6 | 8.0.30703 7 | 2.0 8 | {d5a17cef-e6a6-459d-961f-588a1a1dcd49} 9 | Exe 10 | FSharpMVC.Tests 11 | Figment.Tests 12 | v4.0 13 | FSharpMVC.Tests 14 | 15 | 16 | true 17 | full 18 | false 19 | false 20 | bin\Debug\ 21 | DEBUG;TRACE 22 | 3 23 | bin\Debug\Figment.Tests.XML 24 | 25 | 26 | pdbonly 27 | true 28 | true 29 | bin\Release\ 30 | TRACE 31 | 3 32 | bin\Release\Figment.Tests.XML 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | ..\packages\FSharpx.Core.1.6.4\lib\40\Fsharpx.Core.dll 47 | True 48 | 49 | 50 | ..\packages\Fuchu.0.2.0\lib\net40-client\Fuchu.dll 51 | True 52 | 53 | 54 | ..\packages\Microsoft.Web.Infrastructure.1.0.0.0\lib\net40\Microsoft.Web.Infrastructure.dll 55 | True 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | ..\packages\Microsoft.AspNet.WebPages.1.0.20105.408\lib\net40\System.Web.Helpers.dll 67 | True 68 | 69 | 70 | ..\packages\Microsoft.AspNet.Mvc.3.0.20105.1\lib\net40\System.Web.Mvc.dll 71 | True 72 | 73 | 74 | ..\packages\Microsoft.AspNet.Razor.1.0.20105.408\lib\net40\System.Web.Razor.dll 75 | True 76 | 77 | 78 | 79 | ..\packages\Microsoft.AspNet.WebPages.1.0.20105.408\lib\net40\System.Web.WebPages.dll 80 | True 81 | 82 | 83 | ..\packages\Microsoft.AspNet.WebPages.1.0.20105.408\lib\net40\System.Web.WebPages.Deployment.dll 84 | True 85 | 86 | 87 | ..\packages\Microsoft.AspNet.WebPages.1.0.20105.408\lib\net40\System.Web.WebPages.Razor.dll 88 | True 89 | 90 | 91 | 92 | 93 | Figment 94 | {a080b979-6e39-44c4-ac1a-4850e32c355a} 95 | True 96 | 97 | 98 | 99 | 106 | -------------------------------------------------------------------------------- /Figment/Result.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | [] 4 | module Result = 5 | 6 | open System 7 | open System.Linq 8 | open System.Web 9 | open System.Web.UI 10 | open System.Web.Mvc 11 | open System.Web.Routing 12 | open Figment.Helpers 13 | open Figment.Extensions 14 | open FSharpx 15 | open FSharpx.Reader 16 | 17 | let result = ReaderBuilder() 18 | 19 | let empty : FAction = EmptyResult() |> fromActionResult 20 | 21 | let view viewName model = 22 | let viewData = ViewDataDictionary(Model = model) 23 | ViewResult(ViewData = viewData, ViewName = viewName) |> fromActionResult 24 | 25 | let notFound () = raise <| HttpException(404, "Not found") 26 | 27 | let notFoundOrView viewName = 28 | function 29 | | None -> notFound() 30 | | Some x -> view viewName x 31 | 32 | let content s = 33 | ContentResult(Content = s) |> fromActionResult 34 | 35 | let htmlcontent x = x |> htmlencode |> content 36 | 37 | let contentf f = Printf.kprintf content f 38 | 39 | let htmlcontentf f = Printf.kprintf htmlcontent f 40 | 41 | let redirect url = 42 | RedirectResult(url) |> fromActionResult 43 | 44 | let redirectf f = Printf.kprintf redirect f 45 | 46 | let redirectToRoute (routeValues: RouteValueDictionary) = 47 | RedirectToRouteResult(routeValues) |> fromActionResult 48 | 49 | let unauthorized : FAction = HttpUnauthorizedResult() |> fromActionResult 50 | 51 | let status code : FAction = 52 | fun ctx -> ctx.Response.StatusCode <- code 53 | 54 | let contentType t : FAction = 55 | fun ctx -> ctx.Response.ContentType <- t 56 | 57 | let charset c : FAction = 58 | fun ctx -> ctx.Response.Charset <- c 59 | 60 | let header name value : FAction = 61 | fun ctx -> ctx.Response.AppendHeader(name, value) 62 | 63 | let vary x = header "Vary" x 64 | 65 | let allow (methods: #seq) = header "Allow" (System.String.Join(", ", methods)) 66 | 67 | let fileStream contentType name stream = 68 | FileStreamResult(stream, contentType, FileDownloadName = name) |> fromActionResult 69 | 70 | let filePath contentType path = 71 | FilePathResult(path, contentType) |> fromActionResult 72 | 73 | let fileContent contentType name bytes = 74 | FileContentResult(bytes, contentType, FileDownloadName = name) |> fromActionResult 75 | 76 | let json data = 77 | JsonResult(Data = data, JsonRequestBehavior = JsonRequestBehavior.AllowGet) |> fromActionResult 78 | 79 | let write (text: string) : FAction = 80 | fun ctx -> 81 | ctx.Response.Write text 82 | 83 | let writefn fmt = Printf.kprintf write fmt 84 | 85 | let jsonp callback data = 86 | result { 87 | let! cb = callback 88 | do! write cb 89 | do! write "(" 90 | do! json data 91 | do! write ")" 92 | do! contentType "application/javascript" 93 | } 94 | 95 | let getQueryString (key: string) (ctx: ControllerContext): string option = 96 | match ctx.Request.QueryString.[key] with 97 | | null -> None 98 | | a -> Some a 99 | 100 | let getQueryStringOrFail (key: string) (ctx: ControllerContext) = 101 | getQueryString key ctx 102 | |> Option.getOrElseF (fun () -> failwithf "Missing required querystring key '%s'" key) 103 | 104 | let setInContext k v (ctx: ControllerContext) = 105 | ctx.[k] <- v 106 | 107 | let getFromContext k (ctx: ControllerContext) = 108 | unbox ctx.[k] 109 | 110 | let xml data = 111 | // charset? 112 | contentType "text/xml" >>. 113 | (fun ctx -> 114 | let serializer = System.Xml.Serialization.XmlSerializer(data.GetType()) 115 | serializer.Serialize(ctx.HttpContext.Response.Output, data)) 116 | 117 | let noCache (ctx: ControllerContext) = 118 | let cache = ctx.Response.Cache 119 | cache.SetExpires(DateTime.UtcNow.AddDays(-1.0)) 120 | cache.SetValidUntilExpires(false) 121 | cache.SetRevalidation(HttpCacheRevalidation.AllCaches) 122 | cache.SetCacheability(HttpCacheability.NoCache) 123 | cache.SetNoStore() 124 | 125 | let setCache (settings: OutputCacheParameters) (ctx: ControllerContext) = 126 | let cachePolicy = ctx.HttpContext.Response.Cache 127 | cachePolicy.SetExpires(ctx.HttpContext.Timestamp.AddSeconds(float settings.Duration)) 128 | // TODO set the other cache parameters 129 | 130 | let setHttpCookie (c: HttpCookie) (ctx: ControllerContext) = 131 | ctx.Response.SetCookie c 132 | 133 | let getHttpCookie (name: string) (ctx: ControllerContext) = 134 | match ctx.Request.Cookies.[name] with 135 | | null -> None 136 | | a -> Some a 137 | 138 | let removeHttpCookie (name: string) (ctx: ControllerContext) = 139 | match getHttpCookie name ctx with 140 | | None -> () 141 | | Some cookie -> 142 | let expiration = 143 | if cookie.Expires = DateTime.MinValue 144 | then cookie.Expires 145 | else cookie.Expires.AddYears(-1) 146 | let expiredCookie = HttpCookie(name = cookie.Name, 147 | Domain = cookie.Domain, 148 | Expires = expiration, 149 | HttpOnly = cookie.HttpOnly, 150 | Path = cookie.Path, 151 | Secure = cookie.Secure) 152 | setHttpCookie expiredCookie ctx 153 | 154 | 155 | let internal flashCookieKey = "FigmentFlash" 156 | let internal flashContextKey = obj() 157 | 158 | // TODO encrypt 159 | // see http://www.codinginstinct.com/2008/09/encrypt-cookie-using-machine-key.html 160 | let setFlash (value: string) = 161 | setHttpCookie (HttpCookie(name = flashCookieKey, value = base64encode value)) 162 | 163 | let getFlash x = getFromContext flashContextKey x 164 | -------------------------------------------------------------------------------- /Figment/Routing.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | [] 4 | module Routing = 5 | 6 | open System 7 | open System.Reflection 8 | open System.Text.RegularExpressions 9 | open System.Web 10 | open System.Web.Mvc 11 | open System.Web.Routing 12 | open Binding 13 | open Helpers 14 | open Extensions 15 | open Microsoft.FSharp.Reflection 16 | open RoutingConstraints 17 | open RouteHandlerHelpers 18 | 19 | type HttpMethod = GET | POST | HEAD | DELETE | PUT 20 | 21 | type ActionRegistration = { 22 | routeName: string 23 | action: FAction 24 | route: RouteBase 25 | } with 26 | static member make(routeName, action, route) = 27 | {routeName = routeName; action = action; route = route} 28 | 29 | type RouteCollection with 30 | member private this.GetDefaultRouteValueDictionary() = 31 | RouteValueDictionary(dict ["controller", box "Views"; "action", box "figment"]) 32 | member private this.MapAction(routeConstraint: RouteConstraint, handler: IRouteHandler) = 33 | let route = {new RouteBase() with 34 | override x.GetRouteData ctx = 35 | let data = RouteData(routeHandler = handler, route = x) 36 | for d in this.GetDefaultRouteValueDictionary() do 37 | data.Values.Add(d.Key, d.Value) 38 | if routeConstraint (ctx, data) 39 | then data 40 | else null 41 | override this.GetVirtualPath(ctx, values) = null} 42 | this.Add(route) 43 | route 44 | 45 | member this.MapAction(routeConstraint: RouteConstraint, action: FAction) = 46 | let handler = buildActionRouteHandler action 47 | let route = this.MapAction(routeConstraint, handler) 48 | () 49 | 50 | member this.MapAction(routeConstraint: RouteConstraint, action: FAsyncAction) = 51 | let handler = buildAsyncActionRouteHandler action 52 | let route = this.MapAction(routeConstraint, handler) 53 | () 54 | 55 | member private this.MapWithMethod(url, routeName, httpMethod, handler) = 56 | let httpMethodConstraint = HttpMethodConstraint([| httpMethod |]) 57 | let constraints = RouteValueDictionary(dict [("httpMethod", box httpMethodConstraint)]) 58 | let route = Route(Regex.Replace(url, "^/", ""), this.GetDefaultRouteValueDictionary(), constraints, handler) 59 | this.Add(routeName, route) 60 | route 61 | 62 | member this.MapWithMethod(url, routeName, httpMethod, action: FAction) = 63 | let handler = buildActionRouteHandler action 64 | let route = this.MapWithMethod(url, routeName, httpMethod, handler) 65 | () 66 | 67 | member this.MapWithMethod(url, routeName, httpMethod, action: FAsyncAction) = 68 | let handler = buildAsyncActionRouteHandler action 69 | let route = this.MapWithMethod(url, routeName, httpMethod, handler) 70 | () 71 | 72 | member this.MapGet(url, routeName, action: FAction) = 73 | this.MapWithMethod(url, routeName, "GET", action) 74 | 75 | member this.MapGet(url, routeName, action: FAsyncAction) = 76 | this.MapWithMethod(url, routeName, "GET", action) 77 | 78 | member this.MapPost(url, routeName, action: FAction) = 79 | this.MapWithMethod(url, routeName, "POST", action) 80 | 81 | member this.MapPost(url, routeName, action: FAsyncAction) = 82 | this.MapWithMethod(url, routeName, "POST", action) 83 | 84 | let inline action (routeConstraint: RouteConstraint) (action: FAction) = 85 | RouteTable.Routes.MapAction(routeConstraint, action) 86 | 87 | let inline asyncAction (routeConstraint: RouteConstraint) (action: FAsyncAction) = 88 | RouteTable.Routes.MapAction(routeConstraint, action) 89 | 90 | let inline get url (action: FAction) = 91 | RouteTable.Routes.MapGet(url, null, action) 92 | 93 | let inline getn url routeName (action: FAction) = 94 | RouteTable.Routes.MapGet(url, routeName, action) 95 | 96 | let stripFormatting s = 97 | let parameters = ref [] 98 | let eval (rxMatch: Match) = 99 | let name = rxMatch.Groups.Groups.[1].Value 100 | if rxMatch.Groups.Groups.[2].Captures.Count > 0 101 | then parameters := name::!parameters 102 | sprintf "{%s}" name 103 | let replace = Regex.Replace(s, "{([^:}]+)(:%[^}]+)?}", eval) 104 | let parameters = List.rev !parameters 105 | (replace, parameters) 106 | 107 | let rec bindAll (fTypes: Type list) (parameters: string list) (ctx: ControllerContext) = 108 | match fTypes with 109 | | [] -> failwith "no function types!" 110 | | hd::[] -> [] 111 | | hd::tl -> 112 | match parameters with 113 | | p::ps -> 114 | let v = bindSingleParameterNG hd p ctx.Controller.ValueProvider ctx 115 | v::bindAll tl ps ctx 116 | | [] -> failwith "empty parameters" 117 | 118 | let getnf (fmt: PrintfFormat<'a -> 'b, unit, unit, FAction>) routeName (action: 'a -> 'b) = 119 | let url, parameters = stripFormatting fmt.Value 120 | let args = FSharpType.GetFlattenedFunctionElements(action.GetType()) 121 | let realAction ctx = 122 | let values = bindAll args parameters ctx 123 | let a = FSharpValue.InvokeFunction action values :?> FAction 124 | a ctx 125 | getn url routeName realAction 126 | 127 | let inline getf (fmt: PrintfFormat<'a -> 'b, unit, unit, FAction>) (action: 'a -> 'b) = 128 | getnf fmt null action 129 | 130 | let inline post url (action: FAction) = 131 | RouteTable.Routes.MapPost(url, null, action) 132 | 133 | let register (httpMethod: HttpMethod) url action = 134 | match httpMethod with 135 | | GET -> get url action 136 | | POST -> post url action 137 | | _ -> failwith "Not supported" 138 | 139 | let inline clear () = 140 | RouteTable.Routes.Clear() 141 | -------------------------------------------------------------------------------- /Figment/Extensions.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | open System 4 | open System.Collections 5 | open System.Collections.Generic 6 | open System.Reflection 7 | open System.Web 8 | open System.Web.Mvc 9 | open System.Web.Routing 10 | open Microsoft.FSharp.Reflection 11 | open System.Text.RegularExpressions 12 | open System.Web.Caching 13 | open System.Linq 14 | 15 | [] 16 | module Extensions = 17 | let internal bindingFlags = BindingFlags.NonPublic ||| BindingFlags.Instance 18 | let internal underlyingRequest = typeof.GetField("_httpRequest", bindingFlags) 19 | let internal httpRequestFlags = typeof.GetField("_flags", bindingFlags) 20 | let internal simpleBitVectorClear = httpRequestFlags.FieldType.GetMethod("Clear", bindingFlags) 21 | let internal simpleBitVectorIntValueSet = httpRequestFlags.FieldType.GetProperty("IntegerValue", bindingFlags) 22 | let internal formValidation = 2 23 | 24 | type CaptureCollection with 25 | member this.Captures 26 | with get() = 27 | this |> Seq.cast |> Seq.toArray 28 | 29 | type GroupCollection with 30 | member this.Groups 31 | with get() = 32 | this |> Seq.cast |> Seq.toArray 33 | 34 | type FSharpType with 35 | static member GetFlattenedFunctionElements (functionType: Type) = 36 | let domain, range = FSharpType.GetFunctionElements functionType 37 | if not (FSharpType.IsFunction range) 38 | then domain::[range] 39 | else domain::FSharpType.GetFlattenedFunctionElements(range) 40 | 41 | type FSharpValue with 42 | static member InvokeFunction (f: obj) (args: obj list): obj = 43 | let ft = f.GetType() 44 | if not (FSharpType.IsFunction ft) 45 | then failwith "Not a function!" 46 | let domain, range = FSharpType.GetFunctionElements ft 47 | let fsft = typedefof>.MakeGenericType [| domain; range |] 48 | let bindingFlags = BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public 49 | let r = fsft.InvokeMember("Invoke", bindingFlags, null, f, [| List.head args |]) 50 | if not (FSharpType.IsFunction(r.GetType())) 51 | then box r 52 | else FSharpValue.InvokeFunction r (List.tail args) 53 | 54 | type RouteCollection with 55 | ///

56 | /// Shallow clone of routes. 57 | /// Does not copy route names. 58 | ///

59 | member x.Clone() = 60 | let r = RouteCollection() 61 | use lok = x.GetReadLock() 62 | Seq.iter r.Add x 63 | r 64 | 65 | member x.tryGetRouteData ctx = 66 | match x.GetRouteData ctx with 67 | | null -> None 68 | | a -> Some a 69 | 70 | type Cache with 71 | member x.GetOrAdd(key: string, valueFactory: string -> 'a, ?dependencies, ?absoluteExpiration, ?slidingExpiration, ?priority, ?onRemoveCallback): 'a = 72 | let item = x.Get(key) 73 | if item <> null then 74 | unbox item 75 | else 76 | let dependencies = defaultArg dependencies null 77 | let absoluteExpiration = defaultArg absoluteExpiration Cache.NoAbsoluteExpiration 78 | let slidingExpiration = defaultArg slidingExpiration Cache.NoSlidingExpiration 79 | let priority = defaultArg priority CacheItemPriority.Default 80 | let onRemoveCallback = defaultArg onRemoveCallback (fun _ _ _ -> ()) 81 | let onRemoveCallback = CacheItemRemovedCallback(onRemoveCallback) 82 | let value = valueFactory key 83 | x.Add(key, value, dependencies, absoluteExpiration, slidingExpiration, priority, onRemoveCallback) |> ignore 84 | value 85 | 86 | type HttpRequestBase with 87 | member x.files = 88 | x.Files.AllKeys 89 | |> Seq.map (fun k -> k, x.Files.[k]) 90 | member x.DisableValidation() = 91 | let httpRequest = underlyingRequest.GetValue(x) 92 | let flags = httpRequestFlags.GetValue(httpRequest) 93 | simpleBitVectorIntValueSet.SetValue(flags, 0, null) 94 | httpRequestFlags.SetValue(httpRequest, flags) 95 | 96 | type HttpResponseBase with 97 | member x.Writef fmt = Printf.ksprintf x.Write fmt 98 | member x.Writefn fmt = 99 | let printn (s: string) = 100 | x.Write s 101 | x.Write Environment.NewLine 102 | Printf.ksprintf printn fmt 103 | 104 | type HttpContextBase with 105 | member x.GetService() : 'a = 106 | unbox (x.GetService typeof<'a>) 107 | member x.UnderlyingHttpContext = 108 | x.GetService().Context 109 | 110 | type HttpSessionStateBase with 111 | member x.Get (key: string) = unbox x.[key] 112 | member x.Pop (key: string) = 113 | let v = x.[key] 114 | x.Remove key 115 | unbox v 116 | member x.Set (key: string) v = x.[key] <- v 117 | member x.AsDictionary() = 118 | let notimpl() = raise <| NotImplementedException() 119 | let getEnumerator() = 120 | let sessionEnum = x.GetEnumerator() 121 | let wrapElem (o: obj) = 122 | let key = o :?> string 123 | let value = x.[key] 124 | KeyValuePair(key,value) 125 | { new IEnumerator> with 126 | member e.Current = wrapElem sessionEnum.Current 127 | member e.MoveNext() = sessionEnum.MoveNext() 128 | member e.Reset() = sessionEnum.Reset() 129 | member e.Dispose() = () 130 | member e.Current = box (wrapElem sessionEnum.Current) } 131 | { new IDictionary with 132 | member d.Count = x.Count 133 | member d.IsReadOnly = false 134 | member d.Item 135 | with get k = 136 | let v = x.[k] 137 | if v = null 138 | then raise <| KeyNotFoundException(sprintf "Key '%s' not found" k) 139 | else v 140 | and set k v = x.Add(k,v) 141 | member d.Keys = upcast ResizeArray(x.Keys |> Seq.cast) 142 | member d.Values = 143 | let values = ResizeArray() 144 | for i in 0..x.Count-1 do 145 | values.Add x.[i] 146 | upcast values 147 | member d.Add v = d.Add(v.Key, v.Value) 148 | member d.Add(key,value) = 149 | if key = null 150 | then raise <| ArgumentNullException("key") 151 | if d.ContainsKey key 152 | then raise <| ArgumentException(sprintf "Duplicate key '%s'" key, "key") 153 | x.Add(key,value) 154 | member d.Clear() = x.Clear() 155 | member d.Contains item = x.[item.Key] = item.Value 156 | member d.ContainsKey key = x.[key] <> null 157 | member d.CopyTo(array,arrayIndex) = notimpl() 158 | member d.GetEnumerator() = getEnumerator() 159 | member d.GetEnumerator() = getEnumerator() :> IEnumerator 160 | member d.Remove (item: KeyValuePair) = 161 | if d.Contains item then 162 | x.Remove item.Key 163 | true 164 | else 165 | false 166 | member d.Remove (key: string) = 167 | let exists = d.ContainsKey key 168 | x.Remove key 169 | exists 170 | member d.TryGetValue(key: string, value: byref) = 171 | if d.ContainsKey key then 172 | value <- x.[key] 173 | true 174 | else 175 | false 176 | } 177 | 178 | type ControllerContext with 179 | member x.UrlHelper = UrlHelper(x.RequestContext) 180 | member x.Cache = x.HttpContext.Cache 181 | member x.Session = x.HttpContext.Session 182 | member x.SessionDict = x.Session.AsDictionary() 183 | member x.Request = x.HttpContext.Request 184 | member x.Response = x.HttpContext.Response 185 | member x.Url = x.Request.Url 186 | member x.QueryString = x.Request.QueryString 187 | member x.Form = x.Request.Form 188 | member x.IP = x.Request.UserHostAddress 189 | member x.GetValue n = 190 | let r = x.Controller.ValueProvider.GetValue n 191 | unbox r.RawValue 192 | member x.Item 193 | with get k = unbox x.HttpContext.Items.[k] 194 | and set k v = x.HttpContext.Items.[k] <- v -------------------------------------------------------------------------------- /Figment/Helpers.fs: -------------------------------------------------------------------------------- 1 | namespace Figment 2 | 3 | [] 4 | module Helpers = 5 | 6 | open System 7 | open System.Collections.Specialized 8 | open System.Text 9 | open System.Reflection 10 | open System.Web 11 | open System.Web.Routing 12 | open System.Web.Mvc 13 | open System.Web.Mvc.Async 14 | 15 | open System.Diagnostics 16 | 17 | type FAction = ControllerContext -> unit 18 | 19 | type FAsyncAction = ControllerContext -> Async 20 | 21 | let inline buildActionResult r = 22 | {new ActionResult() with 23 | override x.ExecuteResult ctx = 24 | if ctx = null 25 | then raise <| System.ArgumentNullException("ctx") 26 | else r ctx } 27 | 28 | let inline fromActionResult (a: ActionResult) : FAction = 29 | a.ExecuteResult 30 | 31 | type ControllerFilters = { 32 | actionExecutedFilter: ActionExecutedContext -> unit 33 | actionExecutingFilter: ActionExecutingContext -> unit 34 | authorizationFilter: AuthorizationContext -> unit 35 | exceptionFilter: ExceptionContext -> unit 36 | resultExecutedFilter: ResultExecutedContext -> unit 37 | resultExecutingFilter: ResultExecutingContext -> unit 38 | } 39 | 40 | let DefaultControllerFilters = { 41 | actionExecutedFilter = fun c -> () 42 | actionExecutingFilter = fun c -> () 43 | authorizationFilter = fun c -> () 44 | exceptionFilter = fun c -> () 45 | resultExecutedFilter = fun c -> () 46 | resultExecutingFilter = fun c -> () 47 | } 48 | 49 | type FigmentAsyncController(action: FAsyncAction, filters: ControllerFilters) = 50 | inherit ControllerBase() 51 | override this.ExecuteCore() = 52 | Debug.WriteLine "ExecuteCore" 53 | interface IAsyncController with 54 | member this.BeginExecute(requestContext, cb, state) = 55 | Debug.WriteLine "BeginExecute" 56 | // cb and state are from asp.net 57 | let controllerContext = ControllerContext(requestContext, this) 58 | let abegin, aend, acancel = Async.AsBeginEnd action 59 | let callback r = 60 | Debug.WriteLine "BeginExecute callback" 61 | aend r 62 | cb.Invoke r 63 | 64 | abegin(controllerContext, AsyncCallback(callback), null) 65 | 66 | member this.EndExecute r = 67 | Debug.WriteLine "EndExecute" 68 | member this.Execute r = 69 | Debug.WriteLine "Execute" 70 | 71 | let inline buildRouteHandler f = 72 | { new IRouteHandler with 73 | member x.GetHttpHandler ctx = f ctx } 74 | 75 | let inline buildActionInvoker f = 76 | { new IActionInvoker with 77 | member x.InvokeAction(ctx, actionName) = f ctx actionName } 78 | 79 | let buildControllerFromAction (action: FAction) = 80 | { new Controller(ValidateRequest = false) with 81 | override x.CreateActionInvoker() = 82 | upcast { new ControllerActionInvoker() with 83 | override y.FindAction(ctx, descriptor, actionName) = 84 | { new ActionDescriptor() with 85 | override z.ActionName = actionName 86 | override z.ControllerDescriptor = 87 | { new ControllerDescriptor() with 88 | override a.ControllerType = x.GetType() 89 | override a.FindAction(ctx, actionName) = z 90 | override a.GetCanonicalActions() = [|z|] } 91 | override z.Execute(ctx, param) = 92 | action ctx 93 | buildActionResult ignore |> box 94 | override z.GetParameters() = [||] } } } 95 | 96 | let inline buildControllerFromAsyncAction (action: FAsyncAction) = 97 | new FigmentAsyncController(action, DefaultControllerFilters) 98 | 99 | /// case-insensitive string comparison 100 | let inline (=.) (x: string) (y: string) = 101 | StringComparer.InvariantCultureIgnoreCase.Compare(x,y) = 0 102 | 103 | /// case-insensitive string comparison 104 | let inline (<>.) (x: string) (y: string) = 105 | StringComparer.InvariantCultureIgnoreCase.Compare(x,y) <> 0 106 | 107 | let uncheckedClass = Type.GetType "Microsoft.FSharp.Core.Operators+Unchecked, FSharp.Core, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" 108 | let defaultOfMethod = uncheckedClass.GetMethod "DefaultOf" 109 | 110 | let defaultValueOf (t: Type) = 111 | let genericMethod = defaultOfMethod.MakeGenericMethod [| t |] 112 | genericMethod.Invoke(null, null) 113 | 114 | let inline htmlencode x = HttpUtility.HtmlEncode x 115 | let inline htmldecode x = HttpUtility.HtmlDecode x 116 | let inline urlencode (x: string) = HttpUtility.UrlEncode x 117 | let inline urldecode (x: string) = HttpUtility.UrlDecode x 118 | let inline base64encode (x: string) = 119 | if x = null 120 | then null 121 | else Convert.ToBase64String(Encoding.UTF8.GetBytes(x)) 122 | let inline base64decode (x: string) = 123 | if x = null 124 | then null 125 | else Encoding.UTF8.GetString(Convert.FromBase64String(x)) 126 | 127 | type DelegatingHttpRequestBase(request: HttpRequestBase) = 128 | inherit HttpRequestBase() 129 | override x.AcceptTypes = request.AcceptTypes 130 | override x.AnonymousID = request.AnonymousID 131 | override x.ApplicationPath = request.ApplicationPath 132 | override x.AppRelativeCurrentExecutionFilePath = request.AppRelativeCurrentExecutionFilePath 133 | override x.Browser = request.Browser 134 | override x.ClientCertificate = request.ClientCertificate 135 | override x.ContentEncoding = request.ContentEncoding 136 | override x.ContentLength = request.ContentLength 137 | override x.ContentType = request.ContentType 138 | override x.Cookies = request.Cookies 139 | override x.CurrentExecutionFilePath = request.CurrentExecutionFilePath 140 | override x.FilePath = request.FilePath 141 | override x.Files = request.Files 142 | override x.Filter = request.Filter 143 | override x.Form = request.Form 144 | override x.Headers = request.Headers 145 | override x.HttpMethod = request.HttpMethod 146 | override x.InputStream = request.InputStream 147 | override x.IsAuthenticated = request.IsAuthenticated 148 | override x.IsLocal = request.IsLocal 149 | override x.IsSecureConnection = request.IsSecureConnection 150 | override x.LogonUserIdentity = request.LogonUserIdentity 151 | override x.Params = request.Params 152 | override x.Path = request.Path 153 | override x.PathInfo = request.PathInfo 154 | override x.PhysicalApplicationPath = request.PhysicalApplicationPath 155 | override x.PhysicalPath = request.PhysicalPath 156 | override x.QueryString = request.QueryString 157 | override x.RawUrl = request.RawUrl 158 | override x.RequestType = request.RequestType 159 | override x.ServerVariables = request.ServerVariables 160 | override x.Item with get i = request.[i] 161 | override x.TotalBytes = request.TotalBytes 162 | override x.Url = request.Url 163 | override x.UrlReferrer = request.UrlReferrer 164 | override x.UserAgent = request.UserAgent 165 | override x.UserHostAddress = request.UserHostAddress 166 | override x.UserHostName = request.UserHostName 167 | override x.UserLanguages = request.UserLanguages 168 | override x.BinaryRead count = request.BinaryRead count 169 | override x.Equals o = request.Equals o 170 | override x.GetHashCode() = request.GetHashCode() 171 | override x.MapImageCoordinates imageFieldName = request.MapImageCoordinates imageFieldName 172 | override x.MapPath virtualPath = request.MapPath virtualPath 173 | override x.MapPath(virtualPath, baseVirtualDir, allowCrossAppMapping) = request.MapPath(virtualPath, baseVirtualDir, allowCrossAppMapping) 174 | override x.SaveAs(filename, includeHeaders) = request.SaveAs(filename, includeHeaders) 175 | override x.ToString() = request.ToString() 176 | override x.ValidateInput() = request.ValidateInput() 177 | 178 | 179 | type DelegatingHttpContextBase(ctx: HttpContextBase) = 180 | inherit HttpContextBase() 181 | override x.AllErrors = ctx.AllErrors 182 | override x.Application = ctx.Application 183 | override x.ApplicationInstance = ctx.ApplicationInstance 184 | override x.Cache = ctx.Cache 185 | override x.CurrentHandler = ctx.CurrentHandler 186 | override x.CurrentNotification = ctx.CurrentNotification 187 | override x.Error = ctx.Error 188 | override x.Handler = ctx.Handler 189 | override x.IsCustomErrorEnabled = ctx.IsCustomErrorEnabled 190 | override x.IsDebuggingEnabled = ctx.IsDebuggingEnabled 191 | override x.IsPostNotification = ctx.IsPostNotification 192 | override x.Items = ctx.Items 193 | override x.PreviousHandler = ctx.PreviousHandler 194 | override x.Profile = ctx.Profile 195 | override x.Request = ctx.Request 196 | override x.Response = ctx.Response 197 | override x.Server = ctx.Server 198 | override x.Session = ctx.Session 199 | override x.SkipAuthorization = ctx.SkipAuthorization 200 | override x.Timestamp = ctx.Timestamp 201 | override x.Trace = ctx.Trace 202 | override x.User = ctx.User 203 | override x.AddError e = ctx.AddError e 204 | override x.ClearError() = ctx.ClearError() 205 | override x.Equals o = ctx.Equals o 206 | override x.GetGlobalResourceObject(classKey, resourceKey) = ctx.GetGlobalResourceObject(classKey, resourceKey) 207 | override x.GetGlobalResourceObject(classKey, resourceKey, culture) = ctx.GetGlobalResourceObject(classKey, resourceKey, culture) 208 | override x.GetHashCode() = ctx.GetHashCode() 209 | override x.GetLocalResourceObject(virtualPath, resourceKey) = ctx.GetLocalResourceObject(virtualPath, resourceKey) 210 | override x.GetLocalResourceObject(virtualPath, resourceKey, culture) = ctx.GetLocalResourceObject(virtualPath, resourceKey, culture) 211 | override x.GetSection sectionName = ctx.GetSection sectionName 212 | override x.GetService serviceType = ctx.GetService serviceType 213 | override x.RewritePath path = ctx.RewritePath path 214 | override x.RewritePath(path, rebaseClientPath) = ctx.RewritePath(path, rebaseClientPath) 215 | override x.RewritePath(filePath, pathInfo, querystring) = ctx.RewritePath(filePath, pathInfo, querystring) 216 | override x.RewritePath(filePath, pathInfo, querystring, setClientFilePath) = ctx.RewritePath(filePath, pathInfo, querystring, setClientFilePath) 217 | override x.ToString() = ctx.ToString() 218 | 219 | let withRequest (req: HttpRequestBase) (ctx: HttpContextBase) = 220 | { new DelegatingHttpContextBase(ctx) with 221 | override x.Request = req } 222 | 223 | --------------------------------------------------------------------------------