subtree(users/wpcarro): docking briefcase at '24f5a642'
git-subtree-dir: users/wpcarro git-subtree-mainline:464bbcb15cgit-subtree-split:24f5a642afChange-Id: I6105b3762b79126b3488359c95978cadb3efa789
This commit is contained in:
Vincent Ambo
commit
019f8fd211
766 changed files with 175420 additions and 0 deletions
|
|
@ -0,0 +1,42 @@
|
|||
module FlashCard exposing (render)
|
||||
|
||||
import Html exposing (..)
|
||||
import Html.Attributes exposing (..)
|
||||
import Html.Events exposing (..)
|
||||
import Responsive
|
||||
import State
|
||||
import Tailwind
|
||||
import Theory
|
||||
|
||||
|
||||
render :
|
||||
{ chord : Theory.Chord
|
||||
, visible : Bool
|
||||
}
|
||||
-> Html State.Msg
|
||||
render { chord, visible } =
|
||||
let
|
||||
classes =
|
||||
[ "bg-white"
|
||||
, "fixed"
|
||||
, "top-0"
|
||||
, "left-0"
|
||||
, "z-30"
|
||||
, "w-screen"
|
||||
, "h-screen"
|
||||
, Tailwind.if_ visible "opacity-100" "opacity-0"
|
||||
]
|
||||
in
|
||||
button
|
||||
[ classes |> Tailwind.use |> class ]
|
||||
[ h1
|
||||
[ [ "text-center"
|
||||
, "transform"
|
||||
, "-rotate-90"
|
||||
, Responsive.h1
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
]
|
||||
[ text (Theory.viewChord chord) ]
|
||||
]
|
||||
44
users/wpcarro/website/sandbox/learnpianochords/src/Icon.elm
Normal file
44
users/wpcarro/website/sandbox/learnpianochords/src/Icon.elm
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
module Icon exposing (..)
|
||||
|
||||
import Svg exposing (node, svg)
|
||||
import Svg.Attributes exposing (..)
|
||||
import UI
|
||||
|
||||
|
||||
svgColor color =
|
||||
let
|
||||
classes =
|
||||
case color of
|
||||
UI.Primary ->
|
||||
[ "text-gray-500", "fill-current" ]
|
||||
|
||||
UI.Secondary ->
|
||||
[ "text-gray-300", "fill-current" ]
|
||||
in
|
||||
class <| String.join " " classes
|
||||
|
||||
|
||||
cog =
|
||||
svg [ class "icon-cog", viewBox "0 0 24 24", xmlLang "http://www.w3.org/2000/svg" ]
|
||||
[ Svg.path
|
||||
[ svgColor UI.Primary
|
||||
, d "M6.8 3.45c.87-.52 1.82-.92 2.83-1.17a2.5 2.5 0 0 0 4.74 0c1.01.25 1.96.65 2.82 1.17a2.5 2.5 0 0 0 3.36 3.36c.52.86.92 1.8 1.17 2.82a2.5 2.5 0 0 0 0 4.74c-.25 1.01-.65 1.96-1.17 2.82a2.5 2.5 0 0 0-3.36 3.36c-.86.52-1.8.92-2.82 1.17a2.5 2.5 0 0 0-4.74 0c-1.01-.25-1.96-.65-2.82-1.17a2.5 2.5 0 0 0-3.36-3.36 9.94 9.94 0 0 1-1.17-2.82 2.5 2.5 0 0 0 0-4.74c.25-1.01.65-1.96 1.17-2.82a2.5 2.5 0 0 0 3.36-3.36zM12 16a4 4 0 1 0 0-8 4 4 0 0 0 0 8z"
|
||||
, fill "red"
|
||||
]
|
||||
[]
|
||||
, node "circle"
|
||||
[ svgColor UI.Secondary, cx "12", cy "12", r "2" ]
|
||||
[]
|
||||
]
|
||||
|
||||
|
||||
close =
|
||||
svg [ class "icon-close", viewBox "0 0 24 24", xmlLang "http://www.w3.org/2000/svg" ]
|
||||
[ Svg.path
|
||||
[ svgColor UI.Primary
|
||||
, d "M15.78 14.36a1 1 0 0 1-1.42 1.42l-2.82-2.83-2.83 2.83a1 1 0 1 1-1.42-1.42l2.83-2.82L7.3 8.7a1 1 0 0 1 1.42-1.42l2.83 2.83 2.82-2.83a1 1 0 0 1 1.42 1.42l-2.83 2.83 2.83 2.82z"
|
||||
, fill "red"
|
||||
, fillRule "evenodd"
|
||||
]
|
||||
[]
|
||||
]
|
||||
44
users/wpcarro/website/sandbox/learnpianochords/src/Main.elm
Normal file
44
users/wpcarro/website/sandbox/learnpianochords/src/Main.elm
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
module Main exposing (main)
|
||||
|
||||
import Browser
|
||||
import Html exposing (..)
|
||||
import Misc
|
||||
import Overview
|
||||
import Practice
|
||||
import Preferences
|
||||
import State
|
||||
import Time exposing (..)
|
||||
|
||||
|
||||
subscriptions : State.Model -> Sub State.Msg
|
||||
subscriptions model =
|
||||
if model.isPaused then
|
||||
Sub.none
|
||||
|
||||
else
|
||||
Sub.batch
|
||||
[ Time.every (model.tempo * 2 |> Misc.bpmToMilliseconds |> toFloat) (\_ -> State.ToggleFlashCard)
|
||||
, Time.every (model.tempo |> Misc.bpmToMilliseconds |> toFloat) (\_ -> State.NextChord)
|
||||
]
|
||||
|
||||
|
||||
view : State.Model -> Html State.Msg
|
||||
view model =
|
||||
case model.view of
|
||||
State.Preferences ->
|
||||
Preferences.render model
|
||||
|
||||
State.Practice ->
|
||||
Practice.render model
|
||||
|
||||
State.Overview ->
|
||||
Overview.render model
|
||||
|
||||
|
||||
main =
|
||||
Browser.element
|
||||
{ init = \() -> ( State.init, Cmd.none )
|
||||
, subscriptions = subscriptions
|
||||
, update = State.update
|
||||
, view = view
|
||||
}
|
||||
59
users/wpcarro/website/sandbox/learnpianochords/src/Misc.elm
Normal file
59
users/wpcarro/website/sandbox/learnpianochords/src/Misc.elm
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
module Misc exposing (..)
|
||||
|
||||
import Array exposing (Array)
|
||||
|
||||
|
||||
comesAfter : a -> List a -> Maybe a
|
||||
comesAfter x xs =
|
||||
case xs of
|
||||
[] ->
|
||||
Nothing
|
||||
|
||||
_ :: [] ->
|
||||
Nothing
|
||||
|
||||
y :: z :: rest ->
|
||||
if y == x then
|
||||
Just z
|
||||
|
||||
else
|
||||
comesAfter x (z :: rest)
|
||||
|
||||
|
||||
comesBefore : a -> List a -> Maybe a
|
||||
comesBefore x xs =
|
||||
case xs of
|
||||
[] ->
|
||||
Nothing
|
||||
|
||||
_ :: [] ->
|
||||
Nothing
|
||||
|
||||
y :: z :: rest ->
|
||||
if z == x then
|
||||
Just y
|
||||
|
||||
else
|
||||
comesBefore x (z :: rest)
|
||||
|
||||
|
||||
find : (a -> Bool) -> List a -> Maybe a
|
||||
find pred xs =
|
||||
case xs |> List.filter pred of
|
||||
[] ->
|
||||
Nothing
|
||||
|
||||
x :: _ ->
|
||||
Just x
|
||||
|
||||
|
||||
{-| Return the number of milliseconds that elapse during an interval in a
|
||||
`target` bpm.
|
||||
-}
|
||||
bpmToMilliseconds : Int -> Int
|
||||
bpmToMilliseconds target =
|
||||
let
|
||||
msPerMinute =
|
||||
1000 * 60
|
||||
in
|
||||
round (toFloat msPerMinute / toFloat target)
|
||||
122
users/wpcarro/website/sandbox/learnpianochords/src/Overview.elm
Normal file
122
users/wpcarro/website/sandbox/learnpianochords/src/Overview.elm
Normal file
|
|
@ -0,0 +1,122 @@
|
|||
module Overview exposing (render)
|
||||
|
||||
import Html exposing (..)
|
||||
import Html.Attributes exposing (..)
|
||||
import Html.Events exposing (..)
|
||||
import Responsive
|
||||
import State
|
||||
import Tailwind
|
||||
import UI
|
||||
|
||||
|
||||
header1 : String -> Html msg
|
||||
header1 copy =
|
||||
h2
|
||||
[ [ "text-center"
|
||||
, "pt-24"
|
||||
, "pb-12"
|
||||
, Responsive.h1
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
]
|
||||
[ text copy ]
|
||||
|
||||
|
||||
header2 : String -> Html msg
|
||||
header2 copy =
|
||||
h2
|
||||
[ [ "text-center"
|
||||
, "pb-10"
|
||||
, Responsive.h2
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
]
|
||||
[ text copy ]
|
||||
|
||||
|
||||
paragraph : String -> Html msg
|
||||
paragraph copy =
|
||||
p
|
||||
[ [ "pb-10"
|
||||
, Responsive.h3
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
]
|
||||
[ text copy ]
|
||||
|
||||
|
||||
sect : { title : String, copy : List String } -> Html msg
|
||||
sect { title, copy } =
|
||||
section [] (header2 title :: (copy |> List.map paragraph))
|
||||
|
||||
|
||||
numberedList : List String -> Html msg
|
||||
numberedList items =
|
||||
ol
|
||||
[ [ "list-inside"
|
||||
, "list-decimal"
|
||||
, Responsive.h3
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
]
|
||||
(items |> List.map (\x -> li [ [ "pb-10" ] |> Tailwind.use |> class ] [ text x ]))
|
||||
|
||||
|
||||
render : State.Model -> Html State.Msg
|
||||
render model =
|
||||
div [ [ "container", "mx-auto" ] |> Tailwind.use |> class ]
|
||||
[ header1 "Welcome to LearnPianoChords.app!"
|
||||
, paragraph """
|
||||
Learn Piano Chords helps piano players master chords.
|
||||
"""
|
||||
, paragraph """
|
||||
Chords are the building blocks songwriters use to create
|
||||
music. Whether you're a performer or songwriter, you need
|
||||
to understand chords to unlock your full musical potential.
|
||||
"""
|
||||
, paragraph """
|
||||
I think that if practicing is enjoyable, students will
|
||||
practice more. Practice doesn’t make perfect; perfect
|
||||
practice makes perfect.
|
||||
"""
|
||||
, section []
|
||||
[ header2 "Ready to get started?"
|
||||
, numberedList
|
||||
[ """
|
||||
Sit down at the piano.
|
||||
"""
|
||||
, """
|
||||
Set the tempo at which you would like to practice.
|
||||
"""
|
||||
, """
|
||||
Select the key or keys in which you would like to
|
||||
practice.
|
||||
"""
|
||||
, """
|
||||
When you are ready, close the preferences pane. We will show
|
||||
you the name of a chord, and you should play that chord on
|
||||
the piano.
|
||||
"""
|
||||
, """
|
||||
If you don't know how to play the chord, toggle the piano
|
||||
viewer to see the notes.
|
||||
"""
|
||||
, """
|
||||
At any point while you're training, press the screen to pause
|
||||
or resume your practice.
|
||||
"""
|
||||
]
|
||||
]
|
||||
, div [ [ "text-center", "py-20" ] |> Tailwind.use |> class ]
|
||||
[ UI.simpleButton
|
||||
{ label = "Let's get started"
|
||||
, handleClick = State.SetView State.Preferences
|
||||
, color = UI.Secondary
|
||||
, classes = []
|
||||
}
|
||||
]
|
||||
]
|
||||
194
users/wpcarro/website/sandbox/learnpianochords/src/Piano.elm
Normal file
194
users/wpcarro/website/sandbox/learnpianochords/src/Piano.elm
Normal file
|
|
@ -0,0 +1,194 @@
|
|||
module Piano exposing (render)
|
||||
|
||||
import Browser
|
||||
import Html exposing (..)
|
||||
import Html.Attributes exposing (..)
|
||||
import Html.Events exposing (..)
|
||||
import List.Extra
|
||||
import Theory
|
||||
import UI
|
||||
|
||||
|
||||
type alias KeyMarkup a =
|
||||
{ offset : Int
|
||||
, isHighlit : Bool
|
||||
, note : Theory.Note
|
||||
, isRootNote : Bool
|
||||
}
|
||||
-> Html a
|
||||
|
||||
|
||||
type alias Props =
|
||||
{ chord : Maybe Theory.Chord
|
||||
, firstNote : Theory.Note
|
||||
, lastNote : Theory.Note
|
||||
}
|
||||
|
||||
|
||||
naturalThickness : Int
|
||||
naturalThickness =
|
||||
105
|
||||
|
||||
|
||||
accidentalThickness : Int
|
||||
accidentalThickness =
|
||||
round (toFloat naturalThickness / 2.0)
|
||||
|
||||
|
||||
{-| Convert an integer into its pixel representation for CSS.
|
||||
-}
|
||||
pixelate : Int -> String
|
||||
pixelate x =
|
||||
String.fromInt x ++ "px"
|
||||
|
||||
|
||||
{-| Return the markup for either a white or a black key.
|
||||
-}
|
||||
pianoKey : KeyMarkup a
|
||||
pianoKey { offset, isHighlit, note, isRootNote } =
|
||||
let
|
||||
{ natColor, accColor, hiColor, rootColor } =
|
||||
{ natColor = "bg-white"
|
||||
, accColor = "bg-black"
|
||||
, hiColor = "bg-red-400"
|
||||
, rootColor = "bg-red-600"
|
||||
}
|
||||
|
||||
sharedClasses =
|
||||
[ "box-border"
|
||||
, "absolute"
|
||||
, "border"
|
||||
, "border-black"
|
||||
]
|
||||
|
||||
{ keyLength, keyThickness, keyColor, offsetEdge, extraClasses } =
|
||||
case Theory.keyClass note of
|
||||
Theory.Natural ->
|
||||
{ keyLength = "w-screen"
|
||||
, keyThickness = naturalThickness
|
||||
, keyColor = natColor
|
||||
, offsetEdge = "top"
|
||||
, extraClasses = []
|
||||
}
|
||||
|
||||
Theory.Accidental ->
|
||||
{ keyLength = "w-2/3"
|
||||
, keyThickness = accidentalThickness
|
||||
, keyColor = accColor
|
||||
, offsetEdge = "top"
|
||||
, extraClasses = [ "z-10" ]
|
||||
}
|
||||
in
|
||||
div
|
||||
[ class
|
||||
(case ( isHighlit, isRootNote ) of
|
||||
( False, _ ) ->
|
||||
keyColor
|
||||
|
||||
( True, True ) ->
|
||||
rootColor
|
||||
|
||||
( True, False ) ->
|
||||
hiColor
|
||||
)
|
||||
, class keyLength
|
||||
, style "height" (pixelate keyThickness)
|
||||
, style offsetEdge (String.fromInt offset ++ "px")
|
||||
, class <| String.join " " (List.concat [ sharedClasses, extraClasses ])
|
||||
]
|
||||
[]
|
||||
|
||||
|
||||
{-| A section of the piano consisting of all twelve notes.
|
||||
-}
|
||||
keys :
|
||||
{ start : Theory.Note
|
||||
, end : Theory.Note
|
||||
, highlitNotes : List Theory.Note
|
||||
, rootNote : Maybe Theory.Note
|
||||
}
|
||||
-> List (Html a)
|
||||
keys { start, end, highlitNotes, rootNote } =
|
||||
let
|
||||
isHighlit note =
|
||||
List.member note highlitNotes
|
||||
|
||||
spacing prevOffset prev curr =
|
||||
case ( Theory.keyClass prev, Theory.keyClass curr ) of
|
||||
( Theory.Natural, Theory.Accidental ) ->
|
||||
prevOffset + naturalThickness - round (toFloat accidentalThickness / 2)
|
||||
|
||||
( Theory.Accidental, Theory.Natural ) ->
|
||||
prevOffset + round (toFloat accidentalThickness / 2)
|
||||
|
||||
( Theory.Natural, Theory.Natural ) ->
|
||||
prevOffset + naturalThickness
|
||||
|
||||
-- This pattern should never hit.
|
||||
_ ->
|
||||
prevOffset
|
||||
|
||||
( _, _, notes ) =
|
||||
Theory.notesFromRange start end
|
||||
|> List.reverse
|
||||
|> List.foldl
|
||||
(\curr ( prevOffset, prev, result ) ->
|
||||
case ( prevOffset, prev ) of
|
||||
( Nothing, Nothing ) ->
|
||||
( Just 0
|
||||
, Just curr
|
||||
, pianoKey
|
||||
{ offset = 0
|
||||
, isHighlit = List.member curr highlitNotes
|
||||
, note = curr
|
||||
, isRootNote =
|
||||
rootNote
|
||||
|> Maybe.map (\x -> x == curr)
|
||||
|> Maybe.withDefault False
|
||||
}
|
||||
:: result
|
||||
)
|
||||
|
||||
( Just po, Just p ) ->
|
||||
let
|
||||
offset =
|
||||
spacing po p curr
|
||||
in
|
||||
( Just offset
|
||||
, Just curr
|
||||
, pianoKey
|
||||
{ offset = offset
|
||||
, isHighlit = List.member curr highlitNotes
|
||||
, note = curr
|
||||
, isRootNote =
|
||||
rootNote
|
||||
|> Maybe.map (\x -> x == curr)
|
||||
|> Maybe.withDefault False
|
||||
}
|
||||
:: result
|
||||
)
|
||||
|
||||
-- This pattern should never hit.
|
||||
_ ->
|
||||
( Nothing, Nothing, [] )
|
||||
)
|
||||
( Nothing, Nothing, [] )
|
||||
in
|
||||
notes
|
||||
|
||||
|
||||
{-| Return the HTML that renders a piano representation.
|
||||
-}
|
||||
render : Props -> Html a
|
||||
render { chord } =
|
||||
div [ style "display" "flex" ]
|
||||
(keys
|
||||
{ start = Theory.G3
|
||||
, end = Theory.C6
|
||||
, rootNote = chord |> Maybe.map .note
|
||||
, highlitNotes =
|
||||
chord
|
||||
|> Maybe.andThen Theory.notesForChord
|
||||
|> Maybe.withDefault []
|
||||
}
|
||||
)
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
module Practice exposing (render)
|
||||
|
||||
import FlashCard
|
||||
import Html exposing (..)
|
||||
import Html.Attributes exposing (..)
|
||||
import Html.Events exposing (..)
|
||||
import Icon
|
||||
import Piano
|
||||
import State
|
||||
import Tailwind
|
||||
import Theory
|
||||
import UI
|
||||
|
||||
|
||||
openPreferences : Html State.Msg
|
||||
openPreferences =
|
||||
button
|
||||
[ class "w-48 h-48 absolute left-0 top-0 z-50"
|
||||
, onClick (State.SetView State.Preferences)
|
||||
]
|
||||
[ Icon.cog ]
|
||||
|
||||
|
||||
render : State.Model -> Html State.Msg
|
||||
render model =
|
||||
let
|
||||
( handleClick, buttonText ) =
|
||||
if model.isPaused then
|
||||
( State.Play, "Tap to practice" )
|
||||
|
||||
else
|
||||
( State.Pause, "" )
|
||||
in
|
||||
div []
|
||||
[ openPreferences
|
||||
, case model.selectedChord of
|
||||
Just chord ->
|
||||
FlashCard.render
|
||||
{ chord = chord
|
||||
, visible = model.showFlashCard
|
||||
}
|
||||
|
||||
Nothing ->
|
||||
-- Here I'm abusing the overlayButton component to render text
|
||||
-- horizontally. I should support a UI component for this.
|
||||
UI.overlayButton
|
||||
{ label = "Get ready..."
|
||||
, handleClick = State.DoNothing
|
||||
, isVisible = True
|
||||
}
|
||||
, UI.overlayButton
|
||||
{ label = buttonText
|
||||
, handleClick = handleClick
|
||||
, isVisible = model.isPaused
|
||||
}
|
||||
, Piano.render
|
||||
{ chord = model.selectedChord
|
||||
, firstNote = model.firstNote
|
||||
, lastNote = model.lastNote
|
||||
}
|
||||
]
|
||||
|
|
@ -0,0 +1,148 @@
|
|||
module Preferences exposing (render)
|
||||
|
||||
import Html exposing (..)
|
||||
import Html.Attributes exposing (..)
|
||||
import Html.Events exposing (..)
|
||||
import Icon
|
||||
import Responsive
|
||||
import State
|
||||
import Tailwind
|
||||
import Tempo
|
||||
import Theory
|
||||
import UI
|
||||
|
||||
|
||||
selectKey :
|
||||
State.Model
|
||||
->
|
||||
{ relativeMajor : Theory.Key
|
||||
, relativeMinor : Theory.Key
|
||||
}
|
||||
-> Html State.Msg
|
||||
selectKey model { relativeMajor, relativeMinor } =
|
||||
let
|
||||
active key =
|
||||
List.member key model.whitelistedKeys
|
||||
|
||||
buttonLabel major minor =
|
||||
Theory.viewKey major ++ ", " ++ Theory.viewKey minor
|
||||
in
|
||||
div [ class "flex pt-0" ]
|
||||
[ UI.textToggleButton
|
||||
{ label = buttonLabel relativeMajor relativeMinor
|
||||
, handleClick = State.ToggleKey relativeMajor
|
||||
, classes = [ "flex-1" ]
|
||||
, toggled = active relativeMajor
|
||||
}
|
||||
]
|
||||
|
||||
|
||||
inversionCheckboxes : State.Model -> Html State.Msg
|
||||
inversionCheckboxes model =
|
||||
div []
|
||||
[ h2
|
||||
[ [ "text-gray-500"
|
||||
, "text-center"
|
||||
, "pt-10"
|
||||
, Responsive.h2
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
]
|
||||
[ text "Select inversions" ]
|
||||
, ul
|
||||
[ [ "flex", "justify-center" ] |> Tailwind.use |> class ]
|
||||
(Theory.allInversions
|
||||
|> List.map
|
||||
(\inversion ->
|
||||
li []
|
||||
[ UI.textToggleButton
|
||||
{ label = Theory.inversionName inversion
|
||||
, handleClick = State.ToggleInversion inversion
|
||||
, classes = []
|
||||
, toggled = List.member inversion model.whitelistedInversions
|
||||
}
|
||||
]
|
||||
)
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
keyCheckboxes : State.Model -> Html State.Msg
|
||||
keyCheckboxes model =
|
||||
let
|
||||
majorKey pitchClass =
|
||||
{ pitchClass = pitchClass, mode = Theory.MajorMode }
|
||||
|
||||
minorKey pitchClass =
|
||||
{ pitchClass = pitchClass, mode = Theory.MinorMode }
|
||||
|
||||
circleOfFifths =
|
||||
[ ( Theory.C, Theory.A )
|
||||
, ( Theory.G, Theory.E )
|
||||
, ( Theory.D, Theory.B )
|
||||
, ( Theory.A, Theory.F_sharp )
|
||||
, ( Theory.E, Theory.C_sharp )
|
||||
, ( Theory.B, Theory.G_sharp )
|
||||
, ( Theory.F_sharp, Theory.D_sharp )
|
||||
, ( Theory.C_sharp, Theory.A_sharp )
|
||||
, ( Theory.G_sharp, Theory.F )
|
||||
, ( Theory.D_sharp, Theory.C )
|
||||
, ( Theory.A_sharp, Theory.G )
|
||||
, ( Theory.F, Theory.D )
|
||||
]
|
||||
in
|
||||
div []
|
||||
[ h2
|
||||
[ [ "text-gray-500"
|
||||
, "text-center"
|
||||
, "pt-10"
|
||||
, Responsive.h2
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
]
|
||||
[ text "Select keys" ]
|
||||
, ul []
|
||||
(circleOfFifths
|
||||
|> List.map
|
||||
(\( major, minor ) ->
|
||||
selectKey model
|
||||
{ relativeMajor = majorKey major
|
||||
, relativeMinor = minorKey minor
|
||||
}
|
||||
)
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
closePreferences : Html State.Msg
|
||||
closePreferences =
|
||||
button
|
||||
[ [ "w-48"
|
||||
, "lg:w-32"
|
||||
, "h-48"
|
||||
, "lg:h-32"
|
||||
, "absolute"
|
||||
, "right-0"
|
||||
, "top-0"
|
||||
, "z-10"
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
, onClick (State.SetView State.Practice)
|
||||
]
|
||||
[ Icon.close ]
|
||||
|
||||
|
||||
render : State.Model -> Html State.Msg
|
||||
render model =
|
||||
div [ class "pt-10 pb-20 px-10" ]
|
||||
[ closePreferences
|
||||
, Tempo.render
|
||||
{ tempo = model.tempo
|
||||
, handleInput = State.SetTempo
|
||||
}
|
||||
, inversionCheckboxes model
|
||||
, keyCheckboxes model
|
||||
]
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
module Responsive exposing (..)
|
||||
|
||||
{-| Returns a string containing all of the Tailwind selectors we use to size
|
||||
h2-sized elements across various devices. -}
|
||||
h1 : String
|
||||
h1 =
|
||||
"text-6xl lg:text-4xl"
|
||||
|
||||
{-| Returns a string containing all of the Tailwind selectors we use to size
|
||||
h2-sized elements across various devices. -}
|
||||
h2 : String
|
||||
h2 =
|
||||
"text-5xl lg:text-3xl"
|
||||
|
||||
{-| Returns a string containing all of the Tailwind selectors we use to size
|
||||
h3-sized elements across various devices. -}
|
||||
h3 : String
|
||||
h3 =
|
||||
"text-4xl lg:text-2xl"
|
||||
179
users/wpcarro/website/sandbox/learnpianochords/src/State.elm
Normal file
179
users/wpcarro/website/sandbox/learnpianochords/src/State.elm
Normal file
|
|
@ -0,0 +1,179 @@
|
|||
module State exposing (..)
|
||||
|
||||
import Random
|
||||
import Random.List
|
||||
import Theory
|
||||
|
||||
|
||||
type Msg
|
||||
= NextChord
|
||||
| NewChord Theory.Chord
|
||||
| Play
|
||||
| Pause
|
||||
| SetTempo String
|
||||
| ToggleInversion Theory.ChordInversion
|
||||
| ToggleKey Theory.Key
|
||||
| DoNothing
|
||||
| SetView View
|
||||
| ToggleFlashCard
|
||||
|
||||
|
||||
type View
|
||||
= Preferences
|
||||
| Practice
|
||||
| Overview
|
||||
|
||||
|
||||
type alias Model =
|
||||
{ whitelistedChords : List Theory.Chord
|
||||
, whitelistedChordTypes : List Theory.ChordType
|
||||
, whitelistedInversions : List Theory.ChordInversion
|
||||
, whitelistedPitchClasses : List Theory.PitchClass
|
||||
, whitelistedKeys : List Theory.Key
|
||||
, selectedChord : Maybe Theory.Chord
|
||||
, isPaused : Bool
|
||||
, tempo : Int
|
||||
, firstNote : Theory.Note
|
||||
, lastNote : Theory.Note
|
||||
, view : View
|
||||
, showFlashCard : Bool
|
||||
}
|
||||
|
||||
|
||||
{-| The initial state for the application.
|
||||
-}
|
||||
init : Model
|
||||
init =
|
||||
let
|
||||
( firstNote, lastNote ) =
|
||||
( Theory.C3, Theory.C6 )
|
||||
|
||||
inversions =
|
||||
[ Theory.Root ]
|
||||
|
||||
chordTypes =
|
||||
Theory.allChordTypes
|
||||
|
||||
pitchClasses =
|
||||
Theory.allPitchClasses
|
||||
|
||||
keys =
|
||||
[ { pitchClass = Theory.C, mode = Theory.MajorMode } ]
|
||||
in
|
||||
{ whitelistedChords =
|
||||
keys
|
||||
|> List.concatMap Theory.chordsForKey
|
||||
|> List.filter (\chord -> List.member chord.chordInversion inversions)
|
||||
, whitelistedChordTypes = chordTypes
|
||||
, whitelistedInversions = inversions
|
||||
, whitelistedPitchClasses = pitchClasses
|
||||
, whitelistedKeys = keys
|
||||
, selectedChord = Nothing
|
||||
, isPaused = True
|
||||
, tempo = 10
|
||||
, firstNote = firstNote
|
||||
, lastNote = lastNote
|
||||
, view = Overview
|
||||
, showFlashCard = True
|
||||
}
|
||||
|
||||
|
||||
{-| Now that we have state, we need a function to change the state.
|
||||
-}
|
||||
update : Msg -> Model -> ( Model, Cmd Msg )
|
||||
update msg model =
|
||||
case msg of
|
||||
DoNothing ->
|
||||
( model, Cmd.none )
|
||||
|
||||
SetView x ->
|
||||
( { model
|
||||
| view = x
|
||||
, isPaused = True
|
||||
}
|
||||
, Cmd.none
|
||||
)
|
||||
|
||||
NewChord chord ->
|
||||
( { model | selectedChord = Just chord }
|
||||
, Cmd.none
|
||||
)
|
||||
|
||||
NextChord ->
|
||||
( model
|
||||
, Random.generate
|
||||
(\x ->
|
||||
case x of
|
||||
( Just chord, _ ) ->
|
||||
NewChord chord
|
||||
|
||||
( Nothing, _ ) ->
|
||||
DoNothing
|
||||
)
|
||||
(Random.List.choose model.whitelistedChords)
|
||||
)
|
||||
|
||||
Play ->
|
||||
( { model | isPaused = False }
|
||||
, Cmd.none
|
||||
)
|
||||
|
||||
Pause ->
|
||||
( { model | isPaused = True }
|
||||
, Cmd.none
|
||||
)
|
||||
|
||||
ToggleInversion inversion ->
|
||||
let
|
||||
inversions =
|
||||
if List.member inversion model.whitelistedInversions then
|
||||
List.filter ((/=) inversion) model.whitelistedInversions
|
||||
|
||||
else
|
||||
inversion :: model.whitelistedInversions
|
||||
in
|
||||
( { model
|
||||
| whitelistedInversions = inversions
|
||||
, whitelistedChords =
|
||||
model.whitelistedKeys
|
||||
|> List.concatMap Theory.chordsForKey
|
||||
|> List.filter (\chord -> List.member chord.chordInversion inversions)
|
||||
}
|
||||
, Cmd.none
|
||||
)
|
||||
|
||||
ToggleKey key ->
|
||||
let
|
||||
keys =
|
||||
if List.member key model.whitelistedKeys then
|
||||
List.filter ((/=) key) model.whitelistedKeys
|
||||
|
||||
else
|
||||
key :: model.whitelistedKeys
|
||||
in
|
||||
( { model
|
||||
| whitelistedKeys = keys
|
||||
, whitelistedChords =
|
||||
keys
|
||||
|> List.concatMap Theory.chordsForKey
|
||||
|> List.filter (\chord -> List.member chord.chordInversion model.whitelistedInversions)
|
||||
, selectedChord = Nothing
|
||||
}
|
||||
, Cmd.none
|
||||
)
|
||||
|
||||
SetTempo tempo ->
|
||||
( { model
|
||||
| tempo =
|
||||
case String.toInt tempo of
|
||||
Just x ->
|
||||
x
|
||||
|
||||
Nothing ->
|
||||
model.tempo
|
||||
}
|
||||
, Cmd.none
|
||||
)
|
||||
|
||||
ToggleFlashCard ->
|
||||
( { model | showFlashCard = not model.showFlashCard }, Cmd.none )
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
module Tailwind exposing (..)
|
||||
|
||||
{-| Functions to make Tailwind development in Elm even more pleasant.
|
||||
-}
|
||||
|
||||
|
||||
{-| Conditionally use `class` selection when `condition` is true.
|
||||
-}
|
||||
when : Bool -> String -> String
|
||||
when condition class =
|
||||
if condition then
|
||||
class
|
||||
|
||||
else
|
||||
""
|
||||
|
||||
|
||||
if_ : Bool -> String -> String -> String
|
||||
if_ condition whenTrue whenFalse =
|
||||
if condition then
|
||||
whenTrue
|
||||
|
||||
else
|
||||
whenFalse
|
||||
|
||||
|
||||
use : List String -> String
|
||||
use styles =
|
||||
String.join " " styles
|
||||
33
users/wpcarro/website/sandbox/learnpianochords/src/Tempo.elm
Normal file
33
users/wpcarro/website/sandbox/learnpianochords/src/Tempo.elm
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
module Tempo exposing (render)
|
||||
|
||||
import Html exposing (..)
|
||||
import Html.Attributes exposing (..)
|
||||
import Html.Events exposing (..)
|
||||
import Responsive
|
||||
import Tailwind
|
||||
import UI
|
||||
|
||||
|
||||
type alias Props msg =
|
||||
{ tempo : Int
|
||||
, handleInput : String -> msg
|
||||
}
|
||||
|
||||
|
||||
render : Props msg -> Html msg
|
||||
render { tempo, handleInput } =
|
||||
div [ class "text-center" ]
|
||||
[ p
|
||||
[ [ "py-10"
|
||||
, Responsive.h2
|
||||
]
|
||||
|> Tailwind.use
|
||||
|> class
|
||||
]
|
||||
[ text (String.fromInt tempo ++ " BPM") ]
|
||||
, UI.textField
|
||||
{ placeholderText = "Set tempo..."
|
||||
, handleInput = handleInput
|
||||
, classes = []
|
||||
}
|
||||
]
|
||||
1100
users/wpcarro/website/sandbox/learnpianochords/src/Theory.elm
Normal file
1100
users/wpcarro/website/sandbox/learnpianochords/src/Theory.elm
Normal file
File diff suppressed because it is too large
Load diff
159
users/wpcarro/website/sandbox/learnpianochords/src/UI.elm
Normal file
159
users/wpcarro/website/sandbox/learnpianochords/src/UI.elm
Normal file
|
|
@ -0,0 +1,159 @@
|
|||
module UI exposing (..)
|
||||
|
||||
import Html exposing (..)
|
||||
import Html.Attributes exposing (..)
|
||||
import Html.Events exposing (..)
|
||||
import Responsive
|
||||
import Tailwind
|
||||
|
||||
|
||||
type Color
|
||||
= Primary
|
||||
| Secondary
|
||||
|
||||
|
||||
bgForColor : Color -> String
|
||||
bgForColor color =
|
||||
case color of
|
||||
Primary ->
|
||||
"bg-gray-600"
|
||||
|
||||
Secondary ->
|
||||
"bg-gray-300"
|
||||
|
||||
|
||||
textForColor : Color -> String
|
||||
textForColor color =
|
||||
case color of
|
||||
Primary ->
|
||||
"text-white"
|
||||
|
||||
Secondary ->
|
||||
"text-black"
|
||||
|
||||
|
||||
simpleButton :
|
||||
{ label : String
|
||||
, handleClick : msg
|
||||
, color : Color
|
||||
, classes : List String
|
||||
}
|
||||
-> Html msg
|
||||
simpleButton { label, handleClick, color, classes } =
|
||||
let
|
||||
buttonClasses =
|
||||
[ bgForColor color
|
||||
, textForColor color
|
||||
, "py-10"
|
||||
, "lg:py-6"
|
||||
, "px-20"
|
||||
, "lg:px-12"
|
||||
, "rounded-lg"
|
||||
, Responsive.h2
|
||||
]
|
||||
in
|
||||
button
|
||||
[ class (Tailwind.use <| List.concat [ buttonClasses, classes ])
|
||||
, onClick handleClick
|
||||
]
|
||||
[ text label ]
|
||||
|
||||
|
||||
textToggleButton :
|
||||
{ label : String
|
||||
, handleClick : msg
|
||||
, classes : List String
|
||||
, toggled : Bool
|
||||
}
|
||||
-> Html msg
|
||||
textToggleButton { label, toggled, handleClick, classes } =
|
||||
let
|
||||
( textColor, textTreatment ) =
|
||||
if toggled then
|
||||
( "text-red-600", "underline" )
|
||||
|
||||
else
|
||||
( "text-black", "no-underline" )
|
||||
|
||||
buttonClasses =
|
||||
[ textColor
|
||||
, textTreatment
|
||||
, "py-8"
|
||||
, "lg:py-5"
|
||||
, "px-10"
|
||||
, "lg:px-6"
|
||||
, Responsive.h2
|
||||
]
|
||||
in
|
||||
button
|
||||
[ class (Tailwind.use <| List.concat [ buttonClasses, classes ])
|
||||
, onClick handleClick
|
||||
]
|
||||
[ text label ]
|
||||
|
||||
|
||||
textField :
|
||||
{ placeholderText : String
|
||||
, handleInput : String -> msg
|
||||
, classes : List String
|
||||
}
|
||||
-> Html msg
|
||||
textField { placeholderText, handleInput, classes } =
|
||||
let
|
||||
inputClasses =
|
||||
[ "w-full"
|
||||
, "py-10"
|
||||
, "lg:py-6"
|
||||
, "px-16"
|
||||
, "lg:px-10"
|
||||
, "border"
|
||||
, "rounded-lg"
|
||||
, Responsive.h2
|
||||
]
|
||||
in
|
||||
input
|
||||
[ class (Tailwind.use <| List.concat [ inputClasses, classes ])
|
||||
, onInput handleInput
|
||||
, placeholder placeholderText
|
||||
]
|
||||
[]
|
||||
|
||||
|
||||
overlayButton :
|
||||
{ label : String
|
||||
, handleClick : msg
|
||||
, isVisible : Bool
|
||||
}
|
||||
-> Html msg
|
||||
overlayButton { label, handleClick, isVisible } =
|
||||
let
|
||||
classes =
|
||||
[ "fixed"
|
||||
, "top-0"
|
||||
, "left-0"
|
||||
, "block"
|
||||
, "z-40"
|
||||
, "w-screen"
|
||||
, "h-screen"
|
||||
, Tailwind.if_ isVisible "opacity-100" "opacity-0"
|
||||
]
|
||||
in
|
||||
button
|
||||
[ classes |> Tailwind.use |> class
|
||||
, style "background-color" "rgba(0,0,0,1.0)"
|
||||
, onClick handleClick
|
||||
]
|
||||
[ h1
|
||||
[ style "-webkit-text-stroke-width" "2px"
|
||||
, style "-webkit-text-stroke-color" "black"
|
||||
, class <|
|
||||
Tailwind.use
|
||||
[ "transform"
|
||||
, "-rotate-90"
|
||||
, "text-white"
|
||||
, "font-mono"
|
||||
, Responsive.h1
|
||||
]
|
||||
]
|
||||
[ text label ]
|
||||
]
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
source_up
|
||||
use_nix
|
||||
export SERVER_PORT=3000
|
||||
export CLIENT_PORT=8000
|
||||
export GOOGLE_CLIENT_ID="$(jq -j '.google | .clientId' < ~/briefcase/secrets.json)"
|
||||
export STRIPE_API_KEY="$(jq -j '.stripe | .apiKey' < ~/briefcase/secrets.json)"
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
:set prompt "> "
|
||||
:set -Wall
|
||||
|
||||
:set -XOverloadedStrings
|
||||
:set -XNoImplicitPrelude
|
||||
:set -XRecordWildCards
|
||||
:set -XTypeApplications
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module API where
|
||||
--------------------------------------------------------------------------------
|
||||
import Servant.API
|
||||
|
||||
import qualified Types as T
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type API = "verify"
|
||||
:> ReqBody '[JSON] T.VerifyGoogleSignInRequest
|
||||
:> Post '[JSON] NoContent
|
||||
:<|> "create-payment-intent"
|
||||
:> ReqBody '[JSON] T.PaymentIntent
|
||||
:> Post '[JSON] T.CreatePaymentIntentResponse
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module App where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO hiding (Handler)
|
||||
import Servant
|
||||
import API
|
||||
import Data.String.Conversions (cs)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Network.Wai.Middleware.Cors
|
||||
import GoogleSignIn (EncodedJWT(..), ValidationResult(..))
|
||||
import Utils
|
||||
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import qualified GoogleSignIn
|
||||
import qualified Stripe
|
||||
import qualified Types as T
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
server :: T.Context -> Server API
|
||||
server ctx@T.Context{..} = verifyGoogleSignIn
|
||||
:<|> createPaymentIntent
|
||||
where
|
||||
verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent
|
||||
verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do
|
||||
validationResult <- liftIO $ GoogleSignIn.validateJWT False (EncodedJWT idToken)
|
||||
case validationResult of
|
||||
Valid _ -> do
|
||||
-- If GoogleLinkedAccounts has email from JWT:
|
||||
-- create a new session for email
|
||||
-- Else:
|
||||
-- Redirect the SPA to the sign-up / payment page
|
||||
pure NoContent
|
||||
err -> do
|
||||
throwError err401 { errBody = err |> GoogleSignIn.explainResult |> cs }
|
||||
|
||||
createPaymentIntent :: T.PaymentIntent -> Handler T.CreatePaymentIntentResponse
|
||||
createPaymentIntent pmt = do
|
||||
clientSecret <- liftIO $ Stripe.createPaymentIntent ctx pmt
|
||||
pure T.CreatePaymentIntentResponse{..}
|
||||
|
||||
run :: T.App
|
||||
run = do
|
||||
ctx@T.Context{..} <- ask
|
||||
ctx
|
||||
|> server
|
||||
|> serve (Proxy @ API)
|
||||
|> cors (const $ Just corsPolicy)
|
||||
|> Warp.run contextServerPort
|
||||
|> liftIO
|
||||
pure $ Right ()
|
||||
where
|
||||
corsPolicy :: CorsResourcePolicy
|
||||
corsPolicy = simpleCorsResourcePolicy
|
||||
{ corsOrigins = Just (["http://localhost:8000"], True)
|
||||
, corsMethods = simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"]
|
||||
, corsRequestHeaders = simpleHeaders ++ ["Content-Type", "Authorization"]
|
||||
}
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Fixtures where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Web.JWT
|
||||
import Utils
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified GoogleSignIn
|
||||
import qualified TestUtils
|
||||
import qualified Data.Time.Clock.POSIX as POSIX
|
||||
import qualified System.IO.Unsafe as Unsafe
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | These are the JWT fields that I'd like to overwrite in the `googleJWT`
|
||||
-- function.
|
||||
data JWTFields = JWTFields
|
||||
{ overwriteSigner :: Signer
|
||||
, overwriteAuds :: [StringOrURI]
|
||||
, overwriteIss :: StringOrURI
|
||||
, overwriteExp :: NumericDate
|
||||
}
|
||||
|
||||
defaultJWTFields :: JWTFields
|
||||
defaultJWTFields = do
|
||||
let tenDaysFromToday = POSIX.getPOSIXTime
|
||||
|> Unsafe.unsafePerformIO
|
||||
|> (\x -> x * 60 * 60 * 25 * 10)
|
||||
|> numericDate
|
||||
|> TestUtils.unsafeJust
|
||||
JWTFields
|
||||
{ overwriteSigner = hmacSecret "secret"
|
||||
, overwriteAuds = ["771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"]
|
||||
|> fmap TestUtils.unsafeStringOrURI
|
||||
, overwriteIss = TestUtils.unsafeStringOrURI "accounts.google.com"
|
||||
, overwriteExp = tenDaysFromToday
|
||||
}
|
||||
|
||||
googleJWT :: JWTFields -> GoogleSignIn.EncodedJWT
|
||||
googleJWT JWTFields{..} =
|
||||
encodeSigned signer jwtHeader claimSet
|
||||
|> GoogleSignIn.EncodedJWT
|
||||
where
|
||||
signer :: Signer
|
||||
signer = overwriteSigner
|
||||
|
||||
jwtHeader :: JOSEHeader
|
||||
jwtHeader = JOSEHeader
|
||||
{ typ = Just "JWT"
|
||||
, cty = Nothing
|
||||
, alg = Just RS256
|
||||
, kid = Just "f05415b13acb9590f70df862765c655f5a7a019e"
|
||||
}
|
||||
|
||||
claimSet :: JWTClaimsSet
|
||||
claimSet = JWTClaimsSet
|
||||
{ iss = Just overwriteIss
|
||||
, sub = stringOrURI "114079822315085727057"
|
||||
, aud = overwriteAuds |> Right |> Just
|
||||
-- TODO: Replace date creation with a human-readable date constructor.
|
||||
, Web.JWT.exp = Just overwriteExp
|
||||
, nbf = Nothing
|
||||
-- TODO: Replace date creation with a human-readable date constructor.
|
||||
, iat = numericDate 1596752853
|
||||
, unregisteredClaims = ClaimsMap (Map.fromList [])
|
||||
, jti = stringOrURI "0d3d7fa1fe05bedec0a91c88294936b2b4d1b13c"
|
||||
}
|
||||
|
|
@ -0,0 +1,111 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module GoogleSignIn where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Data.String.Conversions (cs)
|
||||
import Web.JWT
|
||||
import Utils
|
||||
|
||||
import qualified Network.HTTP.Simple as HTTP
|
||||
import qualified Data.Text as Text
|
||||
import qualified Web.JWT as JWT
|
||||
import qualified Data.Time.Clock.POSIX as POSIX
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype EncodedJWT = EncodedJWT Text
|
||||
deriving (Show)
|
||||
|
||||
newtype DecodedJWT = DecodedJWT (JWT UnverifiedJWT)
|
||||
deriving (Show)
|
||||
|
||||
instance Eq DecodedJWT where
|
||||
(DecodedJWT _) == (DecodedJWT _) = True
|
||||
|
||||
data ValidationResult
|
||||
= Valid DecodedJWT
|
||||
| CannotDecodeJWT
|
||||
| GoogleSaysInvalid Text
|
||||
| NoMatchingClientIDs [StringOrURI]
|
||||
| WrongIssuer StringOrURI
|
||||
| StringOrURIParseFailure Text
|
||||
| TimeConversionFailure
|
||||
| MissingRequiredClaim Text
|
||||
| StaleExpiry NumericDate
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Returns True when the supplied `jwt` meets the following criteria:
|
||||
-- * The token has been signed by Google
|
||||
-- * The value of `aud` matches my Google client's ID
|
||||
-- * The value of `iss` matches is "accounts.google.com" or
|
||||
-- "https://accounts.google.com"
|
||||
-- * The `exp` time has not passed
|
||||
--
|
||||
-- Set `skipHTTP` to `True` to avoid making the network request for testing.
|
||||
validateJWT :: Bool
|
||||
-> EncodedJWT
|
||||
-> IO ValidationResult
|
||||
validateJWT skipHTTP (EncodedJWT encodedJWT) = do
|
||||
case encodedJWT |> decode of
|
||||
Nothing -> pure CannotDecodeJWT
|
||||
Just jwt -> do
|
||||
if skipHTTP then
|
||||
continue jwt
|
||||
else do
|
||||
let request = "https://oauth2.googleapis.com/tokeninfo"
|
||||
|> HTTP.setRequestQueryString [ ( "id_token", Just (cs encodedJWT) ) ]
|
||||
res <- HTTP.httpLBS request
|
||||
if HTTP.getResponseStatusCode res /= 200 then
|
||||
pure $ GoogleSaysInvalid (res |> HTTP.getResponseBody |> cs)
|
||||
else
|
||||
continue jwt
|
||||
where
|
||||
continue :: JWT UnverifiedJWT -> IO ValidationResult
|
||||
continue jwt = do
|
||||
let audValues :: [StringOrURI]
|
||||
audValues = jwt |> claims |> auds
|
||||
expectedClientID :: Text
|
||||
expectedClientID = "771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"
|
||||
expectedIssuers :: [Text]
|
||||
expectedIssuers = [ "accounts.google.com"
|
||||
, "https://accounts.google.com"
|
||||
]
|
||||
mExpectedClientID :: Maybe StringOrURI
|
||||
mExpectedClientID = stringOrURI expectedClientID
|
||||
mExpectedIssuers :: Maybe [StringOrURI]
|
||||
mExpectedIssuers = expectedIssuers |> traverse stringOrURI
|
||||
case (mExpectedClientID, mExpectedIssuers) of
|
||||
(Nothing, _) -> pure $ StringOrURIParseFailure expectedClientID
|
||||
(_, Nothing) -> pure $ StringOrURIParseFailure (Text.unwords expectedIssuers)
|
||||
(Just clientID, Just parsedIssuers) ->
|
||||
-- TODO: Prefer reading clientID from a config. I'm thinking of the
|
||||
-- AppContext type having my Configuration
|
||||
if not $ clientID `elem` audValues then
|
||||
pure $ NoMatchingClientIDs audValues
|
||||
else
|
||||
case (jwt |> claims |> iss, jwt |> claims |> JWT.exp) of
|
||||
(Nothing, _) -> pure $ MissingRequiredClaim "iss"
|
||||
(_, Nothing) -> pure $ MissingRequiredClaim "exp"
|
||||
(Just jwtIssuer, Just jwtExpiry) ->
|
||||
if not $ jwtIssuer `elem` parsedIssuers then
|
||||
pure $ WrongIssuer jwtIssuer
|
||||
else do
|
||||
mCurrentTime <- POSIX.getPOSIXTime |> fmap numericDate
|
||||
case mCurrentTime of
|
||||
Nothing -> pure TimeConversionFailure
|
||||
Just currentTime ->
|
||||
if not $ currentTime <= jwtExpiry then
|
||||
pure $ StaleExpiry jwtExpiry
|
||||
else
|
||||
pure $ jwt |> DecodedJWT |> Valid
|
||||
|
||||
-- | Attempt to explain the `ValidationResult` to a human.
|
||||
explainResult :: ValidationResult -> String
|
||||
explainResult (Valid _) = "Everything appears to be valid"
|
||||
explainResult CannotDecodeJWT = "We had difficulty decoding the provided JWT"
|
||||
explainResult (GoogleSaysInvalid x) = "After checking with Google, they claimed that the provided JWT was invalid: " ++ cs x
|
||||
explainResult (NoMatchingClientIDs audFields) = "None of the values in the `aud` field on the provided JWT match our client ID: " ++ show audFields
|
||||
explainResult (WrongIssuer issuer) = "The `iss` field in the provided JWT does not match what we expect: " ++ show issuer
|
||||
explainResult (StringOrURIParseFailure x) = "We had difficulty parsing values as URIs" ++ show x
|
||||
explainResult TimeConversionFailure = "We had difficulty converting the current time to a value we can use to compare with the JWT's `exp` field"
|
||||
explainResult (MissingRequiredClaim claim) = "Your JWT is missing the following claim: " ++ cs claim
|
||||
explainResult (StaleExpiry x) = "The `exp` field on your JWT has expired" ++ x |> show |> cs
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Main where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Prelude (putStr, putStrLn)
|
||||
|
||||
import qualified Types as T
|
||||
import qualified System.Envy as Envy
|
||||
import qualified App
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Attempt to read environment variables from the system and initialize the
|
||||
-- Context data type for our application.
|
||||
getAppContext :: IO (Either String T.Context)
|
||||
getAppContext = do
|
||||
mEnv <- Envy.decodeEnv
|
||||
case mEnv of
|
||||
Left err -> pure $ Left err
|
||||
Right T.Env{..} -> pure $ Right T.Context
|
||||
{ contextGoogleClientID = envGoogleClientID
|
||||
, contextStripeAPIKey = envStripeAPIKey
|
||||
, contextServerPort = envServerPort
|
||||
, contextClientPort = envClientPort
|
||||
}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
mContext <- getAppContext
|
||||
case mContext of
|
||||
Left err -> putStrLn err
|
||||
Right ctx -> do
|
||||
result <- runRIO ctx App.run
|
||||
case result of
|
||||
Left err -> do
|
||||
putStr "Something went wrong when executing the application: "
|
||||
putStrLn $ show err
|
||||
Right _ -> putStrLn "The application successfully executed."
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Spec where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Test.Hspec
|
||||
import Utils
|
||||
import Web.JWT (numericDate, decode)
|
||||
import GoogleSignIn (EncodedJWT(..), DecodedJWT(..), ValidationResult(..))
|
||||
|
||||
import qualified GoogleSignIn
|
||||
import qualified Fixtures as F
|
||||
import qualified TestUtils
|
||||
import qualified Data.Time.Clock.POSIX as POSIX
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = hspec $ do
|
||||
describe "GoogleSignIn" $
|
||||
describe "validateJWT" $ do
|
||||
let validateJWT' = GoogleSignIn.validateJWT True
|
||||
it "returns a decode error when an incorrectly encoded JWT is used" $ do
|
||||
validateJWT' (GoogleSignIn.EncodedJWT "rubbish") `shouldReturn` CannotDecodeJWT
|
||||
|
||||
it "returns validation error when the aud field doesn't match my client ID" $ do
|
||||
let auds = ["wrong-client-id"]
|
||||
|> fmap TestUtils.unsafeStringOrURI
|
||||
encodedJWT = F.defaultJWTFields { F.overwriteAuds = auds }
|
||||
|> F.googleJWT
|
||||
validateJWT' encodedJWT `shouldReturn` NoMatchingClientIDs auds
|
||||
|
||||
it "returns validation success when one of the aud fields matches my client ID" $ do
|
||||
let auds = ["wrong-client-id", "771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"]
|
||||
|> fmap TestUtils.unsafeStringOrURI
|
||||
encodedJWT@(EncodedJWT jwt) =
|
||||
F.defaultJWTFields { F.overwriteAuds = auds }
|
||||
|> F.googleJWT
|
||||
decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT
|
||||
validateJWT' encodedJWT `shouldReturn` Valid decodedJWT
|
||||
|
||||
it "returns validation error when one of the iss field doesn't match accounts.google.com or https://accounts.google.com" $ do
|
||||
let erroneousIssuer = TestUtils.unsafeStringOrURI "not-accounts.google.com"
|
||||
encodedJWT = F.defaultJWTFields { F.overwriteIss = erroneousIssuer }
|
||||
|> F.googleJWT
|
||||
validateJWT' encodedJWT `shouldReturn` WrongIssuer erroneousIssuer
|
||||
|
||||
it "returns validation success when the iss field matches accounts.google.com or https://accounts.google.com" $ do
|
||||
let erroneousIssuer = TestUtils.unsafeStringOrURI "https://accounts.google.com"
|
||||
encodedJWT@(EncodedJWT jwt) =
|
||||
F.defaultJWTFields { F.overwriteIss = erroneousIssuer }
|
||||
|> F.googleJWT
|
||||
decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT
|
||||
validateJWT' encodedJWT `shouldReturn` Valid decodedJWT
|
||||
|
||||
it "fails validation when the exp field has expired" $ do
|
||||
let mErroneousExp = numericDate 0
|
||||
case mErroneousExp of
|
||||
Nothing -> True `shouldBe` False
|
||||
Just erroneousExp -> do
|
||||
let encodedJWT = F.defaultJWTFields { F.overwriteExp = erroneousExp }
|
||||
|> F.googleJWT
|
||||
validateJWT' encodedJWT `shouldReturn` StaleExpiry erroneousExp
|
||||
|
||||
it "passes validation when the exp field is current" $ do
|
||||
mFreshExp <- POSIX.getPOSIXTime
|
||||
|> fmap (\x -> x * 60 * 60 * 24 * 10) -- 10 days later
|
||||
|> fmap numericDate
|
||||
case mFreshExp of
|
||||
Nothing -> True `shouldBe` False
|
||||
Just freshExp -> do
|
||||
let encodedJWT@(EncodedJWT jwt) =
|
||||
F.defaultJWTFields { F.overwriteExp = freshExp }
|
||||
|> F.googleJWT
|
||||
decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT
|
||||
validateJWT' encodedJWT `shouldReturn` Valid decodedJWT
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Stripe where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Prelude (print)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Aeson
|
||||
import Network.HTTP.Req
|
||||
|
||||
import qualified Types as T
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
endpoint :: Text -> Url 'Https
|
||||
endpoint slug =
|
||||
https "api.stripe.com" /: "v1" /: slug
|
||||
|
||||
post :: (FromJSON b) => Text -> Text -> T.PaymentIntent -> IO (JsonResponse b)
|
||||
post apiKey slug T.PaymentIntent{..} = runReq defaultHttpConfig $ do
|
||||
let params = "amount" =: paymentIntentAmount
|
||||
<> "currency" =: paymentIntentCurrency
|
||||
req POST (endpoint slug) (ReqBodyUrlEnc params) jsonResponse (oAuth2Bearer (cs apiKey))
|
||||
|
||||
createPaymentIntent :: T.Context -> T.PaymentIntent -> IO T.Secret
|
||||
createPaymentIntent T.Context{..} pmtIntent = do
|
||||
res <- post contextStripeAPIKey "payment_intents" pmtIntent
|
||||
let T.StripePaymentIntent{..} = responseBody res :: T.StripePaymentIntent
|
||||
pure pmtIntentClientSecret
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module TestUtils where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Web.JWT
|
||||
import Data.String.Conversions (cs)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
unsafeStringOrURI :: String -> StringOrURI
|
||||
unsafeStringOrURI x =
|
||||
case stringOrURI (cs x) of
|
||||
Nothing -> error $ "Failed to convert to StringOrURI: " ++ x
|
||||
Just res -> res
|
||||
|
||||
unsafeJust :: Maybe a -> a
|
||||
unsafeJust Nothing = error "Attempted to force a Nothing to be a something"
|
||||
unsafeJust (Just x) = x
|
||||
|
|
@ -0,0 +1,146 @@
|
|||
--------------------------------------------------------------------------------G
|
||||
module Types where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Data.Aeson
|
||||
import Network.HTTP.Req
|
||||
import Web.Internal.HttpApiData (ToHttpApiData(..))
|
||||
import System.Envy (FromEnv, fromEnv, env)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Read from .envrc
|
||||
data Env = Env
|
||||
{ envGoogleClientID :: !Text
|
||||
, envServerPort :: !Int
|
||||
, envClientPort :: !Int
|
||||
, envStripeAPIKey :: !Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance FromEnv Env where
|
||||
fromEnv _ = do
|
||||
envGoogleClientID <- env "GOOGLE_CLIENT_ID"
|
||||
envStripeAPIKey <- env "STRIPE_API_KEY"
|
||||
envServerPort <- env "SERVER_PORT"
|
||||
envClientPort <- env "CLIENT_PORT"
|
||||
pure Env {..}
|
||||
|
||||
-- | Application context: a combination of Env and additional values.
|
||||
data Context = Context
|
||||
{ contextGoogleClientID :: !Text
|
||||
, contextStripeAPIKey :: !Text
|
||||
, contextServerPort :: !Int
|
||||
, contextClientPort :: !Int
|
||||
}
|
||||
|
||||
-- | Top-level except for our application, as RIO recommends defining.
|
||||
type Failure = ()
|
||||
|
||||
-- | When our app executes along the "happy path" this is the type of result it
|
||||
-- produces.
|
||||
type Success = ()
|
||||
|
||||
-- | This is our application monad.
|
||||
type AppM = RIO Context
|
||||
|
||||
-- | The concrete type of our application.
|
||||
type App = AppM (Either Failure Success)
|
||||
|
||||
data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest
|
||||
{ idToken :: !Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance FromJSON VerifyGoogleSignInRequest where
|
||||
parseJSON = withObject "VerifyGoogleSignInRequest" $ \x -> do
|
||||
idToken <- x .: "idToken"
|
||||
pure VerifyGoogleSignInRequest{..}
|
||||
|
||||
data GoogleLinkedAccount = GoogleLinkedAccount
|
||||
{
|
||||
-- { googleLinkedAccountUUID :: UUID
|
||||
-- , googleLinkedAccountEmail :: Email
|
||||
-- , googleLinkedAccountTsCreated :: Timestamp
|
||||
googleLinkedAccountGivenName :: !(Maybe Text)
|
||||
, googleLinkedAccountFamilyName :: !(Maybe Text)
|
||||
, googleLinkedAccountFullName :: !(Maybe Text)
|
||||
-- , googleLinkedAccountPictureURL :: URL
|
||||
-- , googleLinkedAccountLocale :: Maybe Locale
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data PayingCustomer = PayingCustomer
|
||||
{
|
||||
-- { payingCustomerAccountUUID :: UUID
|
||||
-- , payingCustomerTsCreated :: Timestamp
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data Session = Session
|
||||
{
|
||||
-- { sessionUUID :: UUID
|
||||
-- , sessionAccountUUID :: UUID
|
||||
-- , sessionTsCreated :: Timestamp
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data CurrencyCode = USD
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON CurrencyCode where
|
||||
toJSON USD = String "usd"
|
||||
|
||||
instance FromJSON CurrencyCode where
|
||||
parseJSON = withText "CurrencyCode" $ \x ->
|
||||
case x of
|
||||
"usd" -> pure USD
|
||||
_ -> fail "Expected a valid currency code like: \"usd\""
|
||||
|
||||
instance ToHttpApiData CurrencyCode where
|
||||
toQueryParam USD = "usd"
|
||||
|
||||
data PaymentIntent = PaymentIntent
|
||||
{ paymentIntentAmount :: !Int
|
||||
, paymentIntentCurrency :: !CurrencyCode
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON PaymentIntent where
|
||||
toJSON PaymentIntent{..} =
|
||||
object [ "amount" .= paymentIntentAmount
|
||||
, "currency" .= paymentIntentCurrency
|
||||
]
|
||||
|
||||
instance FromJSON PaymentIntent where
|
||||
parseJSON = withObject "" $ \x -> do
|
||||
paymentIntentAmount <- x .: "amount"
|
||||
paymentIntentCurrency <- x .: "currency"
|
||||
pure PaymentIntent{..}
|
||||
|
||||
instance QueryParam PaymentIntent where
|
||||
queryParam = undefined
|
||||
|
||||
-- All applications have their secrets... Using the secret type ensures that no
|
||||
-- sensitive information will get printed to the screen.
|
||||
newtype Secret = Secret Text deriving (Eq)
|
||||
|
||||
instance Show Secret where
|
||||
show (Secret _) = "[REDACTED]"
|
||||
|
||||
instance ToJSON Secret where
|
||||
toJSON (Secret x) = toJSON x
|
||||
|
||||
instance FromJSON Secret where
|
||||
parseJSON = withText "Secret" $ \x -> pure $ Secret x
|
||||
|
||||
data CreatePaymentIntentResponse = CreatePaymentIntentResponse
|
||||
{ clientSecret :: Secret
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON CreatePaymentIntentResponse where
|
||||
toJSON CreatePaymentIntentResponse{..} =
|
||||
object [ "clientSecret" .= clientSecret
|
||||
]
|
||||
|
||||
data StripePaymentIntent = StripePaymentIntent
|
||||
{ pmtIntentClientSecret :: Secret
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance FromJSON StripePaymentIntent where
|
||||
parseJSON = withObject "StripeCreatePaymentIntentResponse" $ \x -> do
|
||||
pmtIntentClientSecret <- x .: "client_secret"
|
||||
pure StripePaymentIntent{..}
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Utils where
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.Function ((&))
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
(|>) :: a -> (a -> b) -> b
|
||||
(|>) = (&)
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
let
|
||||
briefcase = import <briefcase> {};
|
||||
in briefcase.buildHaskell.program {
|
||||
name = "server";
|
||||
srcs = builtins.path {
|
||||
path = ./.;
|
||||
name = "LearnPianoChords-server-src";
|
||||
};
|
||||
ghcExtensions = [
|
||||
"OverloadedStrings"
|
||||
"NoImplicitPrelude"
|
||||
"RecordWildCards"
|
||||
"TypeApplications"
|
||||
];
|
||||
deps = hpkgs: with hpkgs; [
|
||||
servant-server
|
||||
aeson
|
||||
wai-cors
|
||||
warp
|
||||
jwt
|
||||
unordered-containers
|
||||
base64
|
||||
http-conduit
|
||||
rio
|
||||
envy
|
||||
req
|
||||
];
|
||||
}
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
<!DOCTYPE html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
<meta charset="UTF-8" />
|
||||
<title>Google Sign-in</title>
|
||||
<script src="https://apis.google.com/js/platform.js" async defer></script>
|
||||
<meta name="google-signin-client_id" content="771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com">
|
||||
</head>
|
||||
<body>
|
||||
<div class="g-signin2" data-onsuccess="onSignIn"></div>
|
||||
<a href="#" onclick="signOut();">Sign out</a>
|
||||
<script>
|
||||
function onSignIn(googleUser) {
|
||||
var idToken = googleUser.getAuthResponse().id_token;
|
||||
fetch('http://localhost:3000/verify', {
|
||||
method: 'POST',
|
||||
headers: {
|
||||
'Content-Type': 'application/json',
|
||||
},
|
||||
body: JSON.stringify({
|
||||
idToken: idToken,
|
||||
})
|
||||
})
|
||||
.then(x => console.log(x))
|
||||
.catch(err => console.error(err));
|
||||
}
|
||||
function signOut() {
|
||||
var auth2 = gapi.auth2.getAuthInstance();
|
||||
auth2.signOut().then(function () {
|
||||
console.log('User signed out.');
|
||||
});
|
||||
}
|
||||
</script>
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
BEGIN TRANSACTION;
|
||||
|
||||
DROP TABLE IF EXISTS GoogleLinkedAccounts;
|
||||
DROP TABLE IF EXISTS PayingCustomers;
|
||||
DROP TABLE IF EXISTS Sessions;
|
||||
|
||||
-- Store some of the information that Google provides to us from the JWT.
|
||||
CREATE TABLE GoogleLinkedAccounts (
|
||||
accountUUID TEXT CHECK(LENGTH(uuid) == 36) NOT NULL UNIQUE,
|
||||
email TEXT NOT NULL UNIQUE,
|
||||
tsCreated TEXT NOT NULL, -- 'YYYY-MM-DD HH:MM:SS'
|
||||
givenName TEXT,
|
||||
familyName TEXT,
|
||||
fullName TEXT,
|
||||
pictureURL TEXT,
|
||||
locale TEXT,
|
||||
PRIMARY KEY (accountUUID)
|
||||
);
|
||||
|
||||
-- Track which of our customers have a paid account.
|
||||
-- Defines a one-to-one relationship between:
|
||||
-- GoogleLinkedAccounts and PayingCustomers
|
||||
CREATE TABLE PayingCustomers (
|
||||
accountUUID TEXT,
|
||||
tsCreated TEXT,
|
||||
PRIMARY KEY (accountUUID),
|
||||
FOREIGN KEY (accountUUID) REFERENCES GoogleLinkedAccounts ON DELETE CASCADE
|
||||
);
|
||||
|
||||
-- Define mobile and web sessions for our users.
|
||||
-- Defines a one-to-many relationship between:
|
||||
-- GoogleLinkedAccounts and Sessions
|
||||
CREATE TABLE Sessions (
|
||||
sessionUUID TEXT CHECK(LENGTH(sessionUUID) == 36) NOT NULL UNIQUE,
|
||||
accountUUID TEXT,
|
||||
tsCreated TEXT NOT NULL, -- 'YYYY-MM-DD HH:MM:SS'
|
||||
PRIMARY KEY (sessionUUID)
|
||||
FOREIGN KEY(accountUUID) REFERENCES GoogleLinkedAccounts ON DELETE CASCADE
|
||||
);
|
||||
|
||||
COMMIT;
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
let
|
||||
briefcase = import <briefcase> {};
|
||||
in briefcase.buildHaskell.shell {
|
||||
deps = hpkgs: with hpkgs; [
|
||||
hspec
|
||||
servant-server
|
||||
aeson
|
||||
wai-cors
|
||||
warp
|
||||
jwt
|
||||
unordered-containers
|
||||
base64
|
||||
http-conduit
|
||||
rio
|
||||
envy
|
||||
req
|
||||
];
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue