bit-badger/myWebLog
1
0
Fork 0
Code Issues 4 Pull Requests Packages Projects Releases 11 Activity

Huge repo reorganization

Browse Source 
In no particular order...
- Created projects using F# generator, using Paket and FAKE
- Split "entities" into their own project, and created interface for
data functions required on those entities
- Renamed "data" project and used it as an implementation of data access
- Created "logic" layer that takes the data interface, and does the
non-persistence-related manipulation of items
- Moved "web" project to "app", and modified Nancy modules to utilize
Logic project and data interface instead of Data project and RethinkDB
connection
- Created test placeholder project; will be filling that out shortly
(TAD?)
This commit is contained in:
Daniel J. Summers
2016-08-06 13:55:49 -05:00
parent 8194649018
commit 710004dfc4
53 changed files with 1418 additions and 572 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
src/MyWebLog.App/AdminModule.fs Normal file
View File

@@ -0,0 +1,21 @@
namespace MyWebLog
open MyWebLog.Data
open MyWebLog.Entities
open MyWebLog.Logic.WebLog
open Nancy
open RethinkDb.Driver.Net
/// Handle /admin routes
type AdminModule(data : IMyWebLogData) as this =
inherit NancyModule("/admin")
do
this.Get.["/"] <- fun _ -> this.Dashboard ()
/// Admin dashboard
member this.Dashboard () =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = DashboardModel(this.Context, this.WebLog, findDashboardCounts data this.WebLog.Id)
model.PageTitle <- Resources.Dashboard
upcast this.View.["admin/dashboard", model]

147
src/MyWebLog.App/App.fs Normal file
View File

@@ -0,0 +1,147 @@
module MyWebLog.App
open MyWebLog
open MyWebLog.Data
open MyWebLog.Data.RethinkDB
open MyWebLog.Entities
open MyWebLog.Logic.WebLog
open Nancy
open Nancy.Authentication.Forms
open Nancy.Bootstrapper
open Nancy.Conventions
open Nancy.Cryptography
open Nancy.Owin
open Nancy.Security
open Nancy.Session.Persistable
//open Nancy.Session.Relational
open Nancy.Session.RethinkDb
open Nancy.TinyIoc
open Nancy.ViewEngines.SuperSimpleViewEngine
open NodaTime
open RethinkDb.Driver.Net
open Suave
open Suave.Owin
open System
open System.Configuration
open System.IO
open System.Text.RegularExpressions
/// Establish the configuration for this instance
let cfg = try AppConfig.FromJson (System.IO.File.ReadAllText "config.json")
with ex -> raise <| ApplicationException(Resources.ErrBadAppConfig, ex)
let data : IMyWebLogData = upcast RethinkMyWebLogData(cfg.DataConfig.Conn, cfg.DataConfig)
do
data.SetUp ()
/// Support RESX lookup via the @Translate SSVE alias
type TranslateTokenViewEngineMatcher() =
static let regex = Regex("@Translate\.(?<TranslationKey>[a-zA-Z0-9-_]+);?", RegexOptions.Compiled)
interface ISuperSimpleViewEngineMatcher with
member this.Invoke (content, model, host) =
let translate (m : Match) =
let key = m.Groups.["TranslationKey"].Value
match MyWebLog.Resources.ResourceManager.GetString key with null -> key | xlat -> xlat
regex.Replace(content, translate)
/// Handle forms authentication
type MyWebLogUser(name, claims) =
interface IUserIdentity with
member this.UserName with get() = name
member this.Claims with get() = claims
type MyWebLogUserMapper(container : TinyIoCContainer) =
interface IUserMapper with
member this.GetUserFromIdentifier (identifier, context) =
match context.Request.PersistableSession.GetOrDefault(Keys.User, User.Empty) with
| user when user.Id = string identifier -> upcast MyWebLogUser(user.PreferredName, user.Claims)
| _ -> null
/// Set up the application environment
type MyWebLogBootstrapper() =
inherit DefaultNancyBootstrapper()
override this.ConfigureRequestContainer (container, context) =
base.ConfigureRequestContainer (container, context)
/// User mapper for forms authentication
container.Register<IUserMapper, MyWebLogUserMapper>()
|> ignore
override this.ConfigureConventions (conventions) =
base.ConfigureConventions conventions
// Make theme content available at [theme-name]/
let addContentDir dir =
let contentDir = Path.Combine [| dir; "content" |]
match Directory.Exists contentDir with
| true -> conventions.StaticContentsConventions.Add
(StaticContentConventionBuilder.AddDirectory ((Path.GetFileName dir), contentDir))
| _ -> ()
conventions.StaticContentsConventions.Add
(StaticContentConventionBuilder.AddDirectory("admin/content", "views/admin/content"))
Directory.EnumerateDirectories (Path.Combine [| "views"; "themes" |])
|> Seq.iter addContentDir
override this.ApplicationStartup (container, pipelines) =
base.ApplicationStartup (container, pipelines)
// Application configuration
container.Register<AppConfig>(cfg)
|> ignore
container.Register<IMyWebLogData>(data)
|> ignore
// NodaTime
container.Register<IClock>(SystemClock.Instance)
|> ignore
// I18N in SSVE
container.Register<seq<ISuperSimpleViewEngineMatcher>>(fun _ _ ->
Seq.singleton (TranslateTokenViewEngineMatcher() :> ISuperSimpleViewEngineMatcher))
|> ignore
// Forms authentication configuration
let auth =
FormsAuthenticationConfiguration(
CryptographyConfiguration =
CryptographyConfiguration(
RijndaelEncryptionProvider(PassphraseKeyGenerator(cfg.AuthEncryptionPassphrase, cfg.AuthSalt)),
DefaultHmacProvider(PassphraseKeyGenerator(cfg.AuthHmacPassphrase, cfg.AuthSalt))),
RedirectUrl = "~/user/logon",
UserMapper = container.Resolve<IUserMapper>())
FormsAuthentication.Enable (pipelines, auth)
// CSRF
Csrf.Enable pipelines
// Sessions
let sessions = RethinkDbSessionConfiguration(cfg.DataConfig.Conn)
sessions.Database <- cfg.DataConfig.Database
//let sessions = RelationalSessionConfiguration(ConfigurationManager.ConnectionStrings.["SessionStore"].ConnectionString)
PersistableSessions.Enable (pipelines, sessions)
()
let version =
let v = Reflection.Assembly.GetExecutingAssembly().GetName().Version
match v.Build with
| 0 -> match v.Minor with 0 -> string v.Major | _ -> sprintf "%d.%d" v.Major v.Minor
| _ -> sprintf "%d.%d.%d" v.Major v.Minor v.Build
|> sprintf "v%s"
/// Set up the request environment
type RequestEnvironment() =
interface IRequestStartup with
member this.Initialize (pipelines, context) =
let establishEnv (ctx : NancyContext) =
ctx.Items.[Keys.RequestStart] <- DateTime.Now.Ticks
match tryFindWebLogByUrlBase data ctx.Request.Url.HostName with
| Some webLog -> ctx.Items.[Keys.WebLog] <- webLog
| None -> // TODO: redirect to domain set up page
ApplicationException (sprintf "%s %s" ctx.Request.Url.HostName Resources.ErrNotConfigured)
|> raise
ctx.Items.[Keys.Version] <- version
null
pipelines.BeforeRequest.AddItemToStartOfPipeline establishEnv
let app = OwinApp.ofMidFunc "/" (NancyMiddleware.UseNancy (NancyOptions()))
let Run () = startWebServer defaultConfig app // webPart

33
src/MyWebLog.App/AppConfig.fs Normal file
View File

@@ -0,0 +1,33 @@
namespace MyWebLog
open MyWebLog.Data.RethinkDB
open Newtonsoft.Json
open System.Text
/// Configuration for this myWebLog instance
type AppConfig =
{ /// The text from which to derive salt to use for passwords
[<JsonProperty("password-salt")>]
PasswordSaltString : string
/// The text from which to derive salt to use for forms authentication
[<JsonProperty("auth-salt")>]
AuthSaltString : string
/// The encryption passphrase to use for forms authentication
[<JsonProperty("encryption-passphrase")>]
AuthEncryptionPassphrase : string
/// The HMAC passphrase to use for forms authentication
[<JsonProperty("hmac-passphrase")>]
AuthHmacPassphrase : string
/// The data configuration
[<JsonProperty("data")>]
DataConfig : DataConfig }
with
/// The salt to use for passwords
member this.PasswordSalt = Encoding.UTF8.GetBytes this.PasswordSaltString
/// The salt to use for forms authentication
member this.AuthSalt = Encoding.UTF8.GetBytes this.AuthSaltString
/// Deserialize the configuration from the JSON file
static member FromJson json =
let cfg = JsonConvert.DeserializeObject<AppConfig> json
{ cfg with DataConfig = DataConfig.Connect cfg.DataConfig }

21
src/MyWebLog.App/AssemblyInfo.fs Normal file
View File

@@ -0,0 +1,21 @@
namespace myWebLog.Web.AssemblyInfo
open System.Reflection
open System.Runtime.CompilerServices
open System.Runtime.InteropServices
[<assembly: AssemblyTitle("MyWebLog.Web")>]
[<assembly: AssemblyDescription("Main Nancy assembly for myWebLog")>]
[<assembly: AssemblyConfiguration("")>]
[<assembly: AssemblyCompany("DJS Consulting")>]
[<assembly: AssemblyProduct("MyWebLog.Web")>]
[<assembly: AssemblyCopyright("Copyright © 2016")>]
[<assembly: AssemblyTrademark("")>]
[<assembly: AssemblyCulture("")>]
[<assembly: ComVisible(false)>]
[<assembly: Guid("e6ee110a-27a6-4a19-b0cb-d24f48f71b53")>]
[<assembly: AssemblyVersion("0.9.1.0")>]
[<assembly: AssemblyFileVersion("1.0.0.0")>]
do
()

88
src/MyWebLog.App/CategoryModule.fs Normal file
View File

@@ -0,0 +1,88 @@
namespace MyWebLog
open MyWebLog.Data
open MyWebLog.Logic.Category
open MyWebLog.Entities
open Nancy
open Nancy.ModelBinding
open Nancy.Security
open RethinkDb.Driver.Net
/// Handle /category and /categories URLs
type CategoryModule(data : IMyWebLogData) as this =
inherit NancyModule()
do
this.Get .["/categories" ] <- fun _ -> this.CategoryList ()
this.Get .["/category/{id}/edit" ] <- fun parms -> this.EditCategory (downcast parms)
this.Post .["/category/{id}/edit" ] <- fun parms -> this.SaveCategory (downcast parms)
this.Delete.["/category/{id}/delete"] <- fun parms -> this.DeleteCategory (downcast parms)
/// Display a list of categories
member this.CategoryList () =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = CategoryListModel(this.Context, this.WebLog,
(findAllCategories data this.WebLog.Id
|> List.map (fun cat -> IndentedCategory.Create cat (fun _ -> false))))
upcast this.View.["/admin/category/list", model]
/// Edit a category
member this.EditCategory (parameters : DynamicDictionary) =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString ()
match (match catId with
| "new" -> Some Category.Empty
| _ -> tryFindCategory data this.WebLog.Id catId) with
| Some cat -> let model = CategoryEditModel(this.Context, this.WebLog, cat)
model.Categories <- findAllCategories data this.WebLog.Id
|> List.map (fun cat -> IndentedCategory.Create cat
(fun c -> c = defaultArg (fst cat).ParentId ""))
upcast this.View.["admin/category/edit", model]
| _ -> this.NotFound ()
/// Save a category
member this.SaveCategory (parameters : DynamicDictionary) =
this.ValidateCsrfToken ()
this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString ()
let form = this.Bind<CategoryForm> ()
let oldCat = match catId with
| "new" -> Some { Category.Empty with WebLogId = this.WebLog.Id }
| _ -> tryFindCategory data this.WebLog.Id catId
match oldCat with
| Some old -> let cat = { old with Name = form.Name
Slug = form.Slug
Description = match form.Description with "" -> None | d -> Some d
ParentId = match form.ParentId with "" -> None | p -> Some p }
let newCatId = saveCategory data cat
match old.ParentId = cat.ParentId with
| true -> ()
| _ -> match old.ParentId with
| Some parentId -> removeCategoryFromParent data this.WebLog.Id parentId newCatId
| _ -> ()
match cat.ParentId with
| Some parentId -> addCategoryToParent data this.WebLog.Id parentId newCatId
| _ -> ()
let model = MyWebLogModel(this.Context, this.WebLog)
{ UserMessage.Empty with
Level = Level.Info
Message = System.String.Format
(Resources.MsgCategoryEditSuccess,
(match catId with "new" -> Resources.Added | _ -> Resources.Updated)) }
|> model.AddMessage
this.Redirect (sprintf "/category/%s/edit" newCatId) model
| _ -> this.NotFound ()
/// Delete a category
member this.DeleteCategory (parameters : DynamicDictionary) =
this.ValidateCsrfToken ()
this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString ()
match tryFindCategory data this.WebLog.Id catId with
| Some cat -> deleteCategory data cat
let model = MyWebLogModel(this.Context, this.WebLog)
{ UserMessage.Empty with Level = Level.Info
Message = System.String.Format(Resources.MsgCategoryDeleted, cat.Name) }
|> model.AddMessage
this.Redirect "/categories" model
| _ -> this.NotFound ()

17
src/MyWebLog.App/Keys.fs Normal file
View File

@@ -0,0 +1,17 @@
[<RequireQualifiedAccess>]
module MyWebLog.Keys
/// Messages stored in the session
let Messages = "messages"
/// The request start time (stored in the context for each request)
let RequestStart = "request-start"
/// The current user
let User = "user"
/// The version of myWebLog
let Version = "version"
/// The web log
let WebLog = "web-log"

31
src/MyWebLog.App/ModuleExtensions.fs Normal file
View File

@@ -0,0 +1,31 @@
[<AutoOpen>]
module MyWebLog.ModuleExtensions
open MyWebLog.Entities
open Nancy
open Nancy.Security
/// Parent class for all myWebLog Nancy modules
type NancyModule with
/// Strongly-typed access to the web log for the current request
member this.WebLog = this.Context.Items.[Keys.WebLog] :?> WebLog
/// Display a view using the theme specified for the web log
member this.ThemedView view (model : MyWebLogModel) : obj =
upcast this.View.[(sprintf "themes/%s/%s" this.WebLog.ThemePath view), model]
/// Return a 404
member this.NotFound () : obj = upcast HttpStatusCode.NotFound
/// Redirect a request, storing messages in the session if they exist
member this.Redirect url (model : MyWebLogModel) : obj =
match List.length model.Messages with
| 0 -> ()
| _ -> this.Session.[Keys.Messages] <- model.Messages
upcast this.Response.AsRedirect(url).WithStatusCode HttpStatusCode.TemporaryRedirect
/// Require a specific level of access for the current web log
member this.RequiresAccessLevel level =
this.RequiresAuthentication()
this.RequiresClaims [| sprintf "%s|%s" this.WebLog.Id level |]

302
src/MyWebLog.App/MyWebLog.App.fsproj Normal file
View File

@@ -0,0 +1,302 @@
<?xml version="1.0" encoding="utf-8"?>
<Project ToolsVersion="12.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<Import Project="$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props" Condition="Exists('$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props')" />
<PropertyGroup>
<Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
<Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
<SchemaVersion>2.0</SchemaVersion>
<ProjectGuid>9cea3a8b-e8aa-44e6-9f5f-2095ceed54eb</ProjectGuid>
<OutputType>Library</OutputType>
<RootNamespace>MyWebLog.App</RootNamespace>
<AssemblyName>MyWebLog.App</AssemblyName>
<TargetFrameworkVersion>v4.5.2</TargetFrameworkVersion>
<TargetFSharpCoreVersion>4.4.0.0</TargetFSharpCoreVersion>
<Name>MyWebLog.App</Name>
</PropertyGroup>
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' ">
<DebugSymbols>true</DebugSymbols>
<DebugType>full</DebugType>
<Optimize>false</Optimize>
<Tailcalls>false</Tailcalls>
<OutputPath>bin\Debug\</OutputPath>
<DefineConstants>DEBUG;TRACE</DefineConstants>
<WarningLevel>3</WarningLevel>
<DocumentationFile>bin\Debug\MyWebLog.App.xml</DocumentationFile>
</PropertyGroup>
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
<DebugType>pdbonly</DebugType>
<Optimize>true</Optimize>
<Tailcalls>true</Tailcalls>
<OutputPath>bin\Release\</OutputPath>
<DefineConstants>TRACE</DefineConstants>
<WarningLevel>3</WarningLevel>
<DocumentationFile>bin\Release\MyWebLog.App.xml</DocumentationFile>
</PropertyGroup>
<ItemGroup>
<Reference Include="mscorlib" />
<Reference Include="FSharp.Core, Version=$(TargetFSharpCoreVersion), Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
<Private>True</Private>
</Reference>
<Reference Include="System" />
<Reference Include="System.Core" />
<Reference Include="System.Numerics" />
<Reference Include="System.ServiceModel" />
</ItemGroup>
<ItemGroup>
<Compile Include="AssemblyInfo.fs" />
<Compile Include="Keys.fs" />
<Compile Include="AppConfig.fs" />
<Compile Include="ViewModels.fs" />
<Compile Include="ModuleExtensions.fs" />
<Compile Include="AdminModule.fs" />
<Compile Include="CategoryModule.fs" />
<Compile Include="PageModule.fs" />
<Compile Include="PostModule.fs" />
<Compile Include="UserModule.fs" />
<Compile Include="App.fs" />
</ItemGroup>
<ItemGroup>
<ProjectReference Include="..\MyWebLog.Data.RethinkDB\MyWebLog.Data.RethinkDB.fsproj">
<Name>MyWebLog.Data.RethinkDB</Name>
<Project>{d6c2be5e-883a-4f34-9905-b730543ca380}</Project>
<Private>True</Private>
</ProjectReference>
<ProjectReference Include="..\MyWebLog.Entities\MyWebLog.Entities.fsproj">
<Name>MyWebLog.Entities</Name>
<Project>{a87f3cf5-2189-442b-8acf-929f5153ac22}</Project>
<Private>True</Private>
</ProjectReference>
<ProjectReference Include="..\MyWebLog.Logic\MyWebLog.Logic.fsproj">
<Name>MyWebLog.Logic</Name>
<Project>{29f6eda3-4f43-4bb3-9c63-ae238a9b7f12}</Project>
<Private>True</Private>
</ProjectReference>
<ProjectReference Include="..\MyWebLog.Resources\MyWebLog.Resources.csproj">
<Name>MyWebLog.Resources</Name>
<Project>{a12ea8da-88bc-4447-90cb-a0e2dcc37523}</Project>
<Private>True</Private>
</ProjectReference>
</ItemGroup>
<PropertyGroup>
<MinimumVisualStudioVersion Condition="'$(MinimumVisualStudioVersion)' == ''">11</MinimumVisualStudioVersion>
</PropertyGroup>
<Choose>
<When Condition="'$(VisualStudioVersion)' == '11.0'">
<PropertyGroup Condition="Exists('$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets')">
<FSharpTargetsPath>$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets</FSharpTargetsPath>
</PropertyGroup>
</When>
<Otherwise>
<PropertyGroup Condition="Exists('$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets')">
<FSharpTargetsPath>$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets</FSharpTargetsPath>
</PropertyGroup>
</Otherwise>
</Choose>
<Import Project="$(FSharpTargetsPath)" Condition="Exists('$(FSharpTargetsPath)')" />
<!-- To modify your build process, add your task inside one of the targets below and uncomment it.
Other similar extension points exist, see Microsoft.Common.targets.
<Target Name="BeforeBuild">
</Target>
<Target Name="AfterBuild">
</Target>
-->
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.0' Or $(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="Common.Logging">
<HintPath>..\packages\Common.Logging\lib\net40\Common.Logging.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.0' Or $(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="Common.Logging.Core">
<HintPath>..\packages\Common.Logging.Core\lib\net40\Common.Logging.Core.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And $(TargetFrameworkVersion) == 'v4.0'">
<ItemGroup>
<Reference Include="FSharp.Compiler.Service">
<HintPath>..\packages\FSharp.Compiler.Service\lib\net40\FSharp.Compiler.Service.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="FSharp.Compiler.Service">
<HintPath>..\packages\FSharp.Compiler.Service\lib\net45\FSharp.Compiler.Service.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.0' Or $(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="CSharpFormat">
<HintPath>..\packages\FSharp.Formatting\lib\net40\CSharpFormat.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
<Reference Include="FSharp.CodeFormat">
<HintPath>..\packages\FSharp.Formatting\lib\net40\FSharp.CodeFormat.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
<Reference Include="FSharp.Formatting.Common">
<HintPath>..\packages\FSharp.Formatting\lib\net40\FSharp.Formatting.Common.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
<Reference Include="FSharp.Literate">
<HintPath>..\packages\FSharp.Formatting\lib\net40\FSharp.Literate.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
<Reference Include="FSharp.Markdown">
<HintPath>..\packages\FSharp.Formatting\lib\net40\FSharp.Markdown.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
<Reference Include="FSharp.MetadataFormat">
<HintPath>..\packages\FSharp.Formatting\lib\net40\FSharp.MetadataFormat.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
<Reference Include="RazorEngine">
<HintPath>..\packages\FSharp.Formatting\lib\net40\RazorEngine.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
<Reference Include="System.Web.Razor">
<HintPath>..\packages\FSharp.Formatting\lib\net40\System.Web.Razor.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="FSharpVSPowerTools.Core">
<HintPath>..\packages\FSharpVSPowerTools.Core\lib\net45\FSharpVSPowerTools.Core.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.0' Or $(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="Nancy">
<HintPath>..\packages\Nancy\lib\net40\Nancy.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.0' Or $(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="Nancy.Authentication.Forms">
<HintPath>..\packages\Nancy.Authentication.Forms\lib\net40\Nancy.Authentication.Forms.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And $(TargetFrameworkVersion) == 'v4.5.2'">
<ItemGroup>
<Reference Include="Nancy.Session.Persistable">
<HintPath>..\packages\Nancy.Session.Persistable\lib\net452\Nancy.Session.Persistable.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And $(TargetFrameworkVersion) == 'v4.5.2'">
<ItemGroup>
<Reference Include="Nancy.Session.RethinkDb">
<HintPath>..\packages\Nancy.Session.RethinkDB\lib\net452\Nancy.Session.RethinkDb.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And $(TargetFrameworkVersion) == 'v4.0'">
<ItemGroup>
<Reference Include="Newtonsoft.Json">
<HintPath>..\packages\Newtonsoft.Json\lib\net40\Newtonsoft.Json.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="Newtonsoft.Json">
<HintPath>..\packages\Newtonsoft.Json\lib\net45\Newtonsoft.Json.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.0' Or $(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="NodaTime">
<HintPath>..\packages\NodaTime\lib\net35-Client\NodaTime.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
<Reference Include="System.Xml">
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="RethinkDb.Driver">
<HintPath>..\packages\RethinkDb.Driver\lib\net45\RethinkDb.Driver.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
<Choose>
<When Condition="$(TargetFrameworkIdentifier) == '.NETFramework' And ($(TargetFrameworkVersion) == 'v4.0' Or $(TargetFrameworkVersion) == 'v4.5' Or $(TargetFrameworkVersion) == 'v4.5.2')">
<ItemGroup>
<Reference Include="Suave">
<HintPath>..\packages\Suave\lib\net40\Suave.dll</HintPath>
<Private>True</Private>
<Paket>True</Paket>
</Reference>
</ItemGroup>
</When>
</Choose>
</Project>

91
src/MyWebLog.App/PageModule.fs Normal file
View File

@@ -0,0 +1,91 @@
namespace MyWebLog
open FSharp.Markdown
open MyWebLog.Data
open MyWebLog.Entities
open MyWebLog.Logic.Page
open Nancy
open Nancy.ModelBinding
open Nancy.Security
open NodaTime
open RethinkDb.Driver.Net
/// Handle /pages and /page URLs
type PageModule(data : IMyWebLogData, clock : IClock) as this =
inherit NancyModule()
do
this.Get .["/pages" ] <- fun _ -> this.PageList ()
this.Get .["/page/{id}/edit" ] <- fun parms -> this.EditPage (downcast parms)
this.Post .["/page/{id}/edit" ] <- fun parms -> this.SavePage (downcast parms)
this.Delete.["/page/{id}/delete"] <- fun parms -> this.DeletePage (downcast parms)
/// List all pages
member this.PageList () =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = PagesModel(this.Context, this.WebLog, (findAllPages data this.WebLog.Id
|> List.map (fun p -> PageForDisplay(this.WebLog, p))))
model.PageTitle <- Resources.Pages
upcast this.View.["admin/page/list", model]
/// Edit a page
member this.EditPage (parameters : DynamicDictionary) =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let pageId = parameters.["id"].ToString ()
match (match pageId with
| "new" -> Some Page.Empty
| _ -> tryFindPage data this.WebLog.Id pageId) with
| Some page -> let rev = match page.Revisions
|> List.sortByDescending (fun r -> r.AsOf)
|> List.tryHead with
| Some r -> r
| _ -> Revision.Empty
let model = EditPageModel(this.Context, this.WebLog, page, rev)
model.PageTitle <- match pageId with "new" -> Resources.AddNewPage | _ -> Resources.EditPage
upcast this.View.["admin/page/edit", model]
| _ -> this.NotFound ()
/// Save a page
member this.SavePage (parameters : DynamicDictionary) =
this.ValidateCsrfToken ()
this.RequiresAccessLevel AuthorizationLevel.Administrator
let pageId = parameters.["id"].ToString ()
let form = this.Bind<EditPageForm> ()
let now = clock.Now.Ticks
match (match pageId with "new" -> Some Page.Empty | _ -> tryFindPage data this.WebLog.Id pageId) with
| Some p -> let page = match pageId with "new" -> { p with WebLogId = this.WebLog.Id } | _ -> p
let pId = { p with
Title = form.Title
Permalink = form.Permalink
PublishedOn = match pageId with "new" -> now | _ -> page.PublishedOn
UpdatedOn = now
Text = match form.Source with
| RevisionSource.Markdown -> Markdown.TransformHtml form.Text
| _ -> form.Text
Revisions = { AsOf = now
SourceType = form.Source
Text = form.Text } :: page.Revisions }
|> savePage data
let model = MyWebLogModel(this.Context, this.WebLog)
{ UserMessage.Empty with
Level = Level.Info
Message = System.String.Format
(Resources.MsgPageEditSuccess,
(match pageId with "new" -> Resources.Added | _ -> Resources.Updated)) }
|> model.AddMessage
this.Redirect (sprintf "/page/%s/edit" pId) model
| _ -> this.NotFound ()
/// Delete a page
member this.DeletePage (parameters : DynamicDictionary) =
this.ValidateCsrfToken ()
this.RequiresAccessLevel AuthorizationLevel.Administrator
let pageId = parameters.["id"].ToString ()
match tryFindPageWithoutRevisions data this.WebLog.Id pageId with
| Some page -> deletePage data page.WebLogId page.Id
let model = MyWebLogModel(this.Context, this.WebLog)
{ UserMessage.Empty with Level = Level.Info
Message = Resources.MsgPageDeleted }
|> model.AddMessage
this.Redirect "/pages" model
| _ -> this.NotFound ()

256
src/MyWebLog.App/PostModule.fs Normal file
View File

@@ -0,0 +1,256 @@
namespace MyWebLog
open FSharp.Markdown
open MyWebLog.Data
open MyWebLog.Entities
open MyWebLog.Logic.Category
open MyWebLog.Logic.Page
open MyWebLog.Logic.Post
open Nancy
open Nancy.ModelBinding
open Nancy.Security
open Nancy.Session.Persistable
open NodaTime
open RethinkDb.Driver.Net
open System
open System.ServiceModel.Syndication
/// Routes dealing with posts (including the home page, /tag, /category, RSS, and catch-all routes)
type PostModule(data : IMyWebLogData, clock : IClock) as this =
inherit NancyModule()
/// Get the page number from the dictionary
let getPage (parameters : DynamicDictionary) =
match parameters.ContainsKey "page" with true -> System.Int32.Parse (parameters.["page"].ToString ()) | _ -> 1
/// Convert a list of posts to a list of posts for display
let forDisplay posts = posts |> List.map (fun post -> PostForDisplay(this.WebLog, post))
/// Generate an RSS/Atom feed of the latest posts
let generateFeed format : obj =
let posts = findFeedPosts data this.WebLog.Id 10
let feed =
SyndicationFeed(
this.WebLog.Name, defaultArg this.WebLog.Subtitle null,
Uri(sprintf "%s://%s" this.Request.Url.Scheme this.WebLog.UrlBase), null,
(match posts |> List.tryHead with
| Some (post, _) -> Instant(post.UpdatedOn).ToDateTimeOffset ()
| _ -> System.DateTimeOffset(System.DateTime.MinValue)),
posts
|> List.map (fun (post, user) ->
let item =
SyndicationItem(
BaseUri = Uri(sprintf "%s://%s/%s" this.Request.Url.Scheme this.WebLog.UrlBase post.Permalink),
PublishDate = Instant(post.PublishedOn).ToDateTimeOffset (),
LastUpdatedTime = Instant(post.UpdatedOn).ToDateTimeOffset (),
Title = TextSyndicationContent(post.Title),
Content = TextSyndicationContent(post.Text, TextSyndicationContentKind.Html))
user
|> Option.iter (fun u -> item.Authors.Add
(SyndicationPerson(u.UserName, u.PreferredName, defaultArg u.Url null)))
post.Categories
|> List.iter (fun c -> item.Categories.Add(SyndicationCategory(c.Name)))
item))
let stream = new IO.MemoryStream()
Xml.XmlWriter.Create(stream)
|> match format with "atom" -> feed.SaveAsAtom10 | _ -> feed.SaveAsRss20
stream.Position <- int64 0
upcast this.Response.FromStream(stream, sprintf "application/%s+xml" format)
do
this.Get .["/" ] <- fun _ -> this.HomePage ()
this.Get .["/{permalink*}" ] <- fun parms -> this.CatchAll (downcast parms)
this.Get .["/posts/page/{page:int}" ] <- fun parms -> this.PublishedPostsPage (getPage <| downcast parms)
this.Get .["/category/{slug}" ] <- fun parms -> this.CategorizedPosts (downcast parms)
this.Get .["/category/{slug}/page/{page:int}"] <- fun parms -> this.CategorizedPosts (downcast parms)
this.Get .["/tag/{tag}" ] <- fun parms -> this.TaggedPosts (downcast parms)
this.Get .["/tag/{tag}/page/{page:int}" ] <- fun parms -> this.TaggedPosts (downcast parms)
this.Get .["/feed" ] <- fun _ -> this.Feed ()
this.Get .["/posts/list" ] <- fun _ -> this.PostList 1
this.Get .["/posts/list/page/{page:int}" ] <- fun parms -> this.PostList (getPage <| downcast parms)
this.Get .["/post/{postId}/edit" ] <- fun parms -> this.EditPost (downcast parms)
this.Post.["/post/{postId}/edit" ] <- fun parms -> this.SavePost (downcast parms)
// ---- Display posts to users ----
/// Display a page of published posts
member this.PublishedPostsPage pageNbr =
let model = PostsModel(this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfPublishedPosts data this.WebLog.Id pageNbr 10 |> forDisplay
model.HasNewer <- match pageNbr with
| 1 -> false
| _ -> match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindNewerPost data (List.last model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindOlderPost data (List.head model.Posts).Post
model.UrlPrefix <- "/posts"
model.PageTitle <- match pageNbr with 1 -> "" | _ -> sprintf "%s%i" Resources.PageHash pageNbr
this.ThemedView "index" model
/// Display either the newest posts or the configured home page
member this.HomePage () =
match this.WebLog.DefaultPage with
| "posts" -> this.PublishedPostsPage 1
| pageId -> match tryFindPageWithoutRevisions data this.WebLog.Id pageId with
| Some page -> let model = PageModel(this.Context, this.WebLog, page)
model.PageTitle <- page.Title
this.ThemedView "page" model
| _ -> this.NotFound ()
/// Derive a post or page from the URL, or redirect from a prior URL to the current one
member this.CatchAll (parameters : DynamicDictionary) =
let url = parameters.["permalink"].ToString ()
match tryFindPostByPermalink data this.WebLog.Id url with
| Some post -> // Hopefully the most common result; the permalink is a permalink!
let model = PostModel(this.Context, this.WebLog, post)
model.NewerPost <- tryFindNewerPost data post
model.OlderPost <- tryFindOlderPost data post
model.PageTitle <- post.Title
this.ThemedView "single" model
| _ -> // Maybe it's a page permalink instead...
match tryFindPageByPermalink data this.WebLog.Id url with
| Some page -> // ...and it is!
let model = PageModel(this.Context, this.WebLog, page)
model.PageTitle <- page.Title
this.ThemedView "page" model
| _ -> // Maybe it's an old permalink for a post
match tryFindPostByPriorPermalink data this.WebLog.Id url with
| Some post -> // Redirect them to the proper permalink
upcast this.Response.AsRedirect(sprintf "/%s" post.Permalink)
.WithStatusCode HttpStatusCode.MovedPermanently
| _ -> this.NotFound ()
/// Display categorized posts
member this.CategorizedPosts (parameters : DynamicDictionary) =
let slug = parameters.["slug"].ToString ()
match tryFindCategoryBySlug data this.WebLog.Id slug with
| Some cat -> let pageNbr = getPage parameters
let model = PostsModel(this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfCategorizedPosts data this.WebLog.Id cat.Id pageNbr 10 |> forDisplay
model.HasNewer <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindNewerCategorizedPost data cat.Id
(List.head model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindOlderCategorizedPost data cat.Id
(List.last model.Posts).Post
model.UrlPrefix <- sprintf "/category/%s" slug
model.PageTitle <- sprintf "\"%s\" Category%s" cat.Name
(match pageNbr with | 1 -> "" | n -> sprintf " | Page %i" n)
model.Subtitle <- Some <| match cat.Description with
| Some desc -> desc
| _ -> sprintf "Posts in the \"%s\" category" cat.Name
this.ThemedView "index" model
| _ -> this.NotFound ()
/// Display tagged posts
member this.TaggedPosts (parameters : DynamicDictionary) =
let tag = parameters.["tag"].ToString ()
let pageNbr = getPage parameters
let model = PostsModel(this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfTaggedPosts data this.WebLog.Id tag pageNbr 10 |> forDisplay
model.HasNewer <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindNewerTaggedPost data tag (List.head model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindOlderTaggedPost data tag (List.last model.Posts).Post
model.UrlPrefix <- sprintf "/tag/%s" tag
model.PageTitle <- sprintf "\"%s\" Tag%s" tag (match pageNbr with 1 -> "" | n -> sprintf " | Page %i" n)
model.Subtitle <- Some <| sprintf "Posts tagged \"%s\"" tag
this.ThemedView "index" model
/// Generate an RSS feed
member this.Feed () =
let query = this.Request.Query :?> DynamicDictionary
match query.ContainsKey "format" with
| true -> match query.["format"].ToString () with
| x when x = "atom" || x = "rss" -> generateFeed x
| x when x = "rss2" -> generateFeed "rss"
| _ -> this.Redirect "/feed" (MyWebLogModel(this.Context, this.WebLog))
| _ -> generateFeed "rss"
// ---- Administer posts ----
/// Display a page of posts in the admin area
member this.PostList pageNbr =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = PostsModel(this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfAllPosts data this.WebLog.Id pageNbr 25 |> forDisplay
model.HasNewer <- pageNbr > 1
model.HasOlder <- List.length model.Posts > 24
model.UrlPrefix <- "/posts/list"
model.PageTitle <- Resources.Posts
upcast this.View.["admin/post/list", model]
/// Edit a post
member this.EditPost (parameters : DynamicDictionary) =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let postId = parameters.["postId"].ToString ()
match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId) with
| Some post -> let rev = match post.Revisions
|> List.sortByDescending (fun r -> r.AsOf)
|> List.tryHead with
| Some r -> r
| None -> Revision.Empty
let model = EditPostModel(this.Context, this.WebLog, post, rev)
model.Categories <- findAllCategories data this.WebLog.Id
|> List.map (fun cat -> string (fst cat).Id,
sprintf "%s%s"
(String.replicate (snd cat) " &nbsp; &nbsp; ")
(fst cat).Name)
model.PageTitle <- match post.Id with "new" -> Resources.AddNewPost | _ -> Resources.EditPost
upcast this.View.["admin/post/edit"]
| _ -> this.NotFound ()
/// Save a post
member this.SavePost (parameters : DynamicDictionary) =
this.RequiresAccessLevel AuthorizationLevel.Administrator
this.ValidateCsrfToken ()
let postId = parameters.["postId"].ToString ()
let form = this.Bind<EditPostForm>()
let now = clock.Now.Ticks
match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId) with
| Some p -> let justPublished = p.PublishedOn = int64 0 && form.PublishNow
let post = match postId with
| "new" -> { p with
WebLogId = this.WebLog.Id
AuthorId = (this.Request.PersistableSession.GetOrDefault<User>
(Keys.User, User.Empty)).Id }
| _ -> p
let pId = { post with
Status = match form.PublishNow with
| true -> PostStatus.Published
| _ -> PostStatus.Draft
Title = form.Title
Permalink = form.Permalink
PublishedOn = match justPublished with true -> now | _ -> int64 0
UpdatedOn = now
Text = match form.Source with
| RevisionSource.Markdown -> Markdown.TransformHtml form.Text
| _ -> form.Text
CategoryIds = Array.toList form.Categories
Tags = form.Tags.Split ','
|> Seq.map (fun t -> t.Trim().ToLowerInvariant())
|> Seq.toList
Revisions = { AsOf = now
SourceType = form.Source
Text = form.Text } :: post.Revisions }
|> savePost data
let model = MyWebLogModel(this.Context, this.WebLog)
{ UserMessage.Empty with
Level = Level.Info
Message = System.String.Format
(Resources.MsgPostEditSuccess,
(match postId with "new" -> Resources.Added | _ -> Resources.Updated),
(match justPublished with true -> Resources.AndPublished | _ -> "")) }
|> model.AddMessage
this.Redirect (sprintf "/post/%s/edit" pId) model
| _ -> this.NotFound ()

65
src/MyWebLog.App/UserModule.fs Normal file
View File

@@ -0,0 +1,65 @@
namespace MyWebLog
open MyWebLog.Data
open MyWebLog.Entities
open MyWebLog.Logic.User
open Nancy
open Nancy.Authentication.Forms
open Nancy.Cryptography
open Nancy.ModelBinding
open Nancy.Security
open Nancy.Session.Persistable
open RethinkDb.Driver.Net
open System.Text
/// Handle /user URLs
type UserModule(data : IMyWebLogData, cfg : AppConfig) as this =
inherit NancyModule("/user")
/// Hash the user's password
let pbkdf2 (pw : string) =
PassphraseKeyGenerator(pw, cfg.PasswordSalt, 4096).GetBytes 512
|> Seq.fold (fun acc byt -> sprintf "%s%s" acc (byt.ToString "x2")) ""
do
this.Get .["/logon" ] <- fun _ -> this.ShowLogOn ()
this.Post.["/logon" ] <- fun parms -> this.DoLogOn (downcast parms)
this.Get .["/logoff"] <- fun _ -> this.LogOff ()
/// Show the log on page
member this.ShowLogOn () =
let model = LogOnModel(this.Context, this.WebLog)
let query = this.Request.Query :?> DynamicDictionary
model.Form.ReturnUrl <- match query.ContainsKey "returnUrl" with true -> query.["returnUrl"].ToString () | _ -> ""
upcast this.View.["admin/user/logon", model]
/// Process a user log on
member this.DoLogOn (parameters : DynamicDictionary) =
this.ValidateCsrfToken ()
let form = this.Bind<LogOnForm> ()
let model = MyWebLogModel(this.Context, this.WebLog)
match tryUserLogOn data form.Email (pbkdf2 form.Password) with
| Some user -> this.Session.[Keys.User] <- user
{ UserMessage.Empty with Level = Level.Info
Message = Resources.MsgLogOnSuccess }
|> model.AddMessage
this.Redirect "" model |> ignore // Save the messages in the session before the Nancy redirect
// TODO: investigate if addMessage should update the session when it's called
upcast this.LoginAndRedirect (System.Guid.Parse user.Id,
fallbackRedirectUrl = defaultArg (Option.ofObj form.ReturnUrl) "/")
| _ -> { UserMessage.Empty with Level = Level.Error
Message = Resources.ErrBadLogOnAttempt }
|> model.AddMessage
this.Redirect (sprintf "/user/logon?returnUrl=%s" form.ReturnUrl) model
/// Log a user off
member this.LogOff () =
// FIXME: why are we getting the user here if we don't do anything with it?
let user = this.Request.PersistableSession.GetOrDefault<User> (Keys.User, User.Empty)
this.Session.DeleteAll ()
let model = MyWebLogModel(this.Context, this.WebLog)
{ UserMessage.Empty with Level = Level.Info
Message = Resources.MsgLogOffSuccess }
|> model.AddMessage
this.Redirect "" model |> ignore
upcast this.LogoutAndRedirect "/"

434
src/MyWebLog.App/ViewModels.fs Normal file
View File

@@ -0,0 +1,434 @@
namespace MyWebLog
open MyWebLog.Entities
open MyWebLog.Logic.WebLog
open Nancy
open Nancy.Session.Persistable
open Newtonsoft.Json
open NodaTime
open NodaTime.Text
open System
/// Levels for a user message
[<RequireQualifiedAccess>]
module Level =
/// An informational message
let Info = "Info"
/// A message regarding a non-fatal but non-optimal condition
let Warning = "WARNING"
/// A message regarding a failure of the expected result
let Error = "ERROR"
/// A message for the user
type UserMessage =
{ /// The level of the message (use Level module constants)
Level : string
/// The text of the message
Message : string
/// Further details regarding the message
Details : string option }
with
/// An empty message
static member Empty =
{ Level = Level.Info
Message = ""
Details = None }
/// Display version
[<JsonIgnore>]
member this.ToDisplay =
let classAndLabel =
dict [
Level.Error, ("danger", Resources.Error)
Level.Warning, ("warning", Resources.Warning)
Level.Info, ("info", "")
]
seq {
yield "<div class=\"alert alert-dismissable alert-"
yield fst classAndLabel.[this.Level]
yield "\" role=\"alert\"><button type=\"button\" class=\"close\" data-dismiss=\"alert\" aria-label=\""
yield Resources.Close
yield "\">&times;</button><strong>"
match snd classAndLabel.[this.Level] with
| "" -> ()
| lbl -> yield lbl.ToUpper ()
yield " &#xbb; "
yield this.Message
yield "</strong>"
match this.Details with
| Some d -> yield "<br />"
yield d
| None -> ()
yield "</div>"
}
|> Seq.reduce (+)
/// Helpers to format local date/time using NodaTime
module FormatDateTime =
/// Convert ticks to a zoned date/time
let zonedTime timeZone ticks = Instant(ticks).InZone(DateTimeZoneProviders.Tzdb.[timeZone])
/// Display a long date
let longDate timeZone ticks =
zonedTime timeZone ticks
|> ZonedDateTimePattern.CreateWithCurrentCulture("MMMM d',' yyyy", DateTimeZoneProviders.Tzdb).Format
/// Display a short date
let shortDate timeZone ticks =
zonedTime timeZone ticks
|> ZonedDateTimePattern.CreateWithCurrentCulture("MMM d',' yyyy", DateTimeZoneProviders.Tzdb).Format
/// Display the time
let time timeZone ticks =
(zonedTime timeZone ticks
|> ZonedDateTimePattern.CreateWithCurrentCulture("h':'mmtt", DateTimeZoneProviders.Tzdb).Format).ToLower()
/// Parent view model for all myWebLog views
type MyWebLogModel(ctx : NancyContext, webLog : WebLog) =
/// Get the messages from the session
let getMessages () =
let msg = ctx.Request.PersistableSession.GetOrDefault<UserMessage list>(Keys.Messages, [])
match List.length msg with
| 0 -> ()
| _ -> ctx.Request.Session.Delete Keys.Messages
msg
/// The web log for this request
member this.WebLog = webLog
/// The subtitle for the webLog (SSVE can't do IsSome that deep)
member this.WebLogSubtitle = defaultArg this.WebLog.Subtitle ""
/// User messages
member val Messages = getMessages () with get, set
/// The currently logged in user
member this.User = ctx.Request.PersistableSession.GetOrDefault<User>(Keys.User, User.Empty)
/// The title of the page
member val PageTitle = "" with get, set
/// The name and version of the application
member this.Generator = sprintf "myWebLog %s" (ctx.Items.[Keys.Version].ToString ())
/// The request start time
member this.RequestStart = ctx.Items.[Keys.RequestStart] :?> int64
/// Is a user authenticated for this request?
member this.IsAuthenticated = "" <> this.User.Id
/// Add a message to the output
member this.AddMessage message = this.Messages <- message :: this.Messages
/// Display a long date
member this.DisplayLongDate ticks = FormatDateTime.longDate this.WebLog.TimeZone ticks
/// Display a short date
member this.DisplayShortDate ticks = FormatDateTime.shortDate this.WebLog.TimeZone ticks
/// Display the time
member this.DisplayTime ticks = FormatDateTime.time this.WebLog.TimeZone ticks
/// The page title with the web log name appended
member this.DisplayPageTitle =
match this.PageTitle with
| "" -> match this.WebLog.Subtitle with
| Some st -> sprintf "%s | %s" this.WebLog.Name st
| None -> this.WebLog.Name
| pt -> sprintf "%s | %s" pt this.WebLog.Name
/// An image with the version and load time in the tool tip
member this.FooterLogo =
seq {
yield "<img src=\"/default/footer-logo.png\" alt=\"myWebLog\" title=\""
yield sprintf "%s %s &bull; " Resources.PoweredBy this.Generator
yield Resources.LoadedIn
yield " "
yield TimeSpan(System.DateTime.Now.Ticks - this.RequestStart).TotalSeconds.ToString "f3"
yield " "
yield Resources.Seconds.ToLower ()
yield "\" />"
}
|> Seq.reduce (+)
// ---- Admin models ----
/// Admin Dashboard view model
type DashboardModel(ctx, webLog, counts : DashboardCounts) =
inherit MyWebLogModel(ctx, webLog)
/// The number of posts for the current web log
member val Posts = counts.Posts with get, set
/// The number of pages for the current web log
member val Pages = counts.Pages with get, set
/// The number of categories for the current web log
member val Categories = counts.Categories with get, set
// ---- Category models ----
type IndentedCategory =
{ Category : Category
Indent : int
Selected : bool }
with
/// Create an indented category
static member Create (cat : Category * int) (isSelected : string -> bool) =
{ Category = fst cat
Indent = snd cat
Selected = isSelected (fst cat).Id }
/// Display name for a category on the list page, complete with indents
member this.ListName = sprintf "%s%s" (String.replicate this.Indent " &#xbb; &nbsp; ") this.Category.Name
/// Display for this category as an option within a select box
member this.Option =
seq {
yield sprintf "<option value=\"%s\"" this.Category.Id
yield (match this.Selected with | true -> """ selected="selected">""" | _ -> ">")
yield String.replicate this.Indent " &nbsp; &nbsp; "
yield this.Category.Name
yield "</option>"
}
|> String.concat ""
/// Does the category have a description?
member this.HasDescription = this.Category.Description.IsSome
/// Model for the list of categories
type CategoryListModel(ctx, webLog, categories) =
inherit MyWebLogModel(ctx, webLog)
/// The categories
member this.Categories : IndentedCategory list = categories
/// Form for editing a category
type CategoryForm(category : Category) =
new() = CategoryForm(Category.Empty)
/// The name of the category
member val Name = category.Name with get, set
/// The slug of the category (used in category URLs)
member val Slug = category.Slug with get, set
/// The description of the category
member val Description = defaultArg category.Description "" with get, set
/// The parent category for this one
member val ParentId = defaultArg category.ParentId "" with get, set
/// Model for editing a category
type CategoryEditModel(ctx, webLog, category) =
inherit MyWebLogModel(ctx, webLog)
/// The form with the category information
member val Form = CategoryForm(category) with get, set
/// The categories
member val Categories : IndentedCategory list = [] with get, set
// ---- Page models ----
/// Model for page display
type PageModel(ctx, webLog, page) =
inherit MyWebLogModel(ctx, webLog)
/// The page to be displayed
member this.Page : Page = page
/// Wrapper for a page with additional properties
type PageForDisplay(webLog, page) =
/// The page
member this.Page : Page = page
/// The time zone of the web log
member this.TimeZone = webLog.TimeZone
/// The date the page was last updated
member this.UpdatedDate = FormatDateTime.longDate this.TimeZone page.UpdatedOn
/// The time the page was last updated
member this.UpdatedTime = FormatDateTime.time this.TimeZone page.UpdatedOn
/// Model for page list display
type PagesModel(ctx, webLog, pages) =
inherit MyWebLogModel(ctx, webLog)
/// The pages
member this.Pages : PageForDisplay list = pages
/// Form used to edit a page
type EditPageForm() =
/// The title of the page
member val Title = "" with get, set
/// The link for the page
member val Permalink = "" with get, set
/// The source type of the revision
member val Source = "" with get, set
/// The text of the revision
member val Text = "" with get, set
/// Whether to show the page in the web log's page list
member val ShowInPageList = false with get, set
/// Fill the form with applicable values from a page
member this.ForPage (page : Page) =
this.Title <- page.Title
this.Permalink <- page.Permalink
this.ShowInPageList <- page.ShowInPageList
this
/// Fill the form with applicable values from a revision
member this.ForRevision rev =
this.Source <- rev.SourceType
this.Text <- rev.Text
this
/// Model for the edit page page
type EditPageModel(ctx, webLog, page, revision) =
inherit MyWebLogModel(ctx, webLog)
/// The page edit form
member val Form = EditPageForm().ForPage(page).ForRevision(revision)
/// The page itself
member this.Page = page
/// The page's published date
member this.PublishedDate = this.DisplayLongDate page.PublishedOn
/// The page's published time
member this.PublishedTime = this.DisplayTime page.PublishedOn
/// The page's last updated date
member this.LastUpdatedDate = this.DisplayLongDate page.UpdatedOn
/// The page's last updated time
member this.LastUpdatedTime = this.DisplayTime page.UpdatedOn
/// Is this a new page?
member this.IsNew = "new" = page.Id
/// Generate a checked attribute if this page shows in the page list
member this.PageListChecked = match page.ShowInPageList with true -> "checked=\"checked\"" | _ -> ""
// ---- Post models ----
/// Model for single post display
type PostModel(ctx, webLog, post) =
inherit MyWebLogModel(ctx, webLog)
/// The post being displayed
member this.Post : Post = post
/// The next newer post
member val NewerPost : Post option = None with get, set
/// The next older post
member val OlderPost : Post option = None with get, set
/// The date the post was published
member this.PublishedDate = this.DisplayLongDate this.Post.PublishedOn
/// The time the post was published
member this.PublishedTime = this.DisplayTime this.Post.PublishedOn
/// Does the post have tags?
member this.HasTags = not (List.isEmpty post.Tags)
/// Get the tags sorted
member this.Tags = post.Tags
|> List.sort
|> List.map (fun tag -> tag, tag.Replace(' ', '+'))
/// Does this post have a newer post?
member this.HasNewer = this.NewerPost.IsSome
/// Does this post have an older post?
member this.HasOlder = this.OlderPost.IsSome
/// Wrapper for a post with additional properties
type PostForDisplay(webLog : WebLog, post : Post) =
/// Turn tags into a pipe-delimited string of tags
let pipedTags tags = tags |> List.reduce (fun acc x -> sprintf "%s | %s" acc x)
/// The actual post
member this.Post = post
/// The time zone for the web log to which this post belongs
member this.TimeZone = webLog.TimeZone
/// The date the post was published
member this.PublishedDate = FormatDateTime.longDate this.TimeZone this.Post.PublishedOn
/// The time the post was published
member this.PublishedTime = FormatDateTime.time this.TimeZone this.Post.PublishedOn
/// Tags
member this.Tags =
match List.length this.Post.Tags with
| 0 -> ""
| 1 | 2 | 3 | 4 | 5 -> this.Post.Tags |> pipedTags
| count -> sprintf "%s %s" (this.Post.Tags |> List.take 3 |> pipedTags)
(System.String.Format(Resources.andXMore, count - 3))
/// Model for all page-of-posts pages
type PostsModel(ctx, webLog) =
inherit MyWebLogModel(ctx, webLog)
/// The subtitle for the page
member val Subtitle : string option = None with get, set
/// The posts to display
member val Posts : PostForDisplay list = [] with get, set
/// The page number of the post list
member val PageNbr = 0 with get, set
/// Whether there is a newer page of posts for the list
member val HasNewer = false with get, set
/// Whether there is an older page of posts for the list
member val HasOlder = true with get, set
/// The prefix for the next/prior links
member val UrlPrefix = "" with get, set
/// The link for the next newer page of posts
member this.NewerLink =
match this.UrlPrefix = "/posts" && this.PageNbr = 2 && this.WebLog.DefaultPage = "posts" with
| true -> "/"
| _ -> sprintf "%s/page/%i" this.UrlPrefix (this.PageNbr - 1)
/// The link for the prior (older) page of posts
member this.OlderLink = sprintf "%s/page/%i" this.UrlPrefix (this.PageNbr + 1)
/// Form for editing a post
type EditPostForm() =
/// The title of the post
member val Title = "" with get, set
/// The permalink for the post
member val Permalink = "" with get, set
/// The source type for this revision
member val Source = "" with get, set
/// The text
member val Text = "" with get, set
/// Tags for the post
member val Tags = "" with get, set
/// The selected category Ids for the post
member val Categories : string[] = [||] with get, set
/// Whether the post should be published
member val PublishNow = true with get, set
/// Fill the form with applicable values from a post
member this.ForPost post =
this.Title <- post.Title
this.Permalink <- post.Permalink
this.Tags <- List.reduce (fun acc x -> sprintf "%s, %s" acc x) post.Tags
this.Categories <- List.toArray post.CategoryIds
this
/// Fill the form with applicable values from a revision
member this.ForRevision rev =
this.Source <- rev.SourceType
this.Text <- rev.Text
this
/// View model for the edit post page
type EditPostModel(ctx, webLog, post, revision) =
inherit MyWebLogModel(ctx, webLog)
/// The form
member val Form = EditPostForm().ForPost(post).ForRevision(revision) with get, set
/// The post being edited
member val Post = post with get, set
/// The categories to which the post may be assigned
member val Categories : (string * string) list = [] with get, set
/// Whether the post is currently published
member this.IsPublished = PostStatus.Published = this.Post.Status
/// The published date
member this.PublishedDate = this.DisplayLongDate this.Post.PublishedOn
/// The published time
member this.PublishedTime = this.DisplayTime this.Post.PublishedOn
// ---- User models ----
/// Form for the log on page
type LogOnForm() =
/// The URL to which the user will be directed upon successful log on
member val ReturnUrl = "" with get, set
/// The e-mail address
member val Email = "" with get, set
/// The user's passwor
member val Password = "" with get, set
/// Model to support the user log on page
type LogOnModel(ctx, webLog) =
inherit MyWebLogModel(ctx, webLog)
/// The log on form
member val Form = LogOnForm() with get, set

7
src/MyWebLog.App/paket.references Normal file
View File

@@ -0,0 +1,7 @@
FSharp.Formatting
Nancy
Nancy.Authentication.Forms
Nancy.Session.RethinkDB
NodaTime
RethinkDb.Driver
Suave